Session CoSMed

iv class="head">

Theory Prelim

section ‹Preliminaries›

theory Prelim
  imports
    "Bounded_Deducibility_Security.Compositional_Reasoning"
    "Fresh_Identifiers.Fresh_String"
begin


subsection‹The basic types›

definition "emptyStr = STR ''''"

(* The users of the system: *)


datatype name = Nam String.literal
definition "emptyName ≡ Nam emptyStr"
datatype inform = Info String.literal
definition "emptyInfo ≡ Info emptyStr"

datatype user = Usr (nameUser : name) (infoUser : inform)
definition "emptyUser ≡ Usr emptyName emptyInfo"
fun niUser where "niUser (Usr name info) = (name,info)"


typedecl raw_data
code_printing type_constructor raw_data ⇀ (Scala) "java.io.File"

(* Images (currently, pdf, to be changed): *)
datatype img  = emptyImg | Imag raw_data
(* Visibility outside the current api: either friends-only or public  *)
datatype vis = Vsb String.literal
(* Accepted values: friend and public  *)
abbreviation "FriendV ≡ Vsb (STR ''friend'')"
abbreviation "PublicV ≡ Vsb (STR ''public'')"
fun stringOfVis where "stringOfVis (Vsb str) = str"

(* A post consists of a string for title, a string for its text,
  a (possibly empty) image and a visibility specification: *)

datatype title = Tit String.literal
definition "emptyTitle ≡ Tit emptyStr"
datatype "text" = Txt String.literal
definition "emptyText ≡ Txt emptyStr"

datatype post = Ntc (titlePost : title) (textPost : "text") (imgPost : img)
(* Setters: *)
fun setTitlePost where "setTitlePost (Ntc title text img) title' = Ntc title' text img"
fun setTextPost where "setTextPost(Ntc title text img) text' = Ntc title text' img"
fun setImgPost where "setImgPost (Ntc title text img) img' = Ntc title text img'"
(*  *)
definition emptyPost :: post where
"emptyPost ≡ Ntc emptyTitle emptyText emptyImg"
(* initially set to the lowest visibility: friend *)

lemma set_get_post[simp]:
"titlePost (setTitlePost ntc title) = title"
"titlePost (setTextPost ntc text) = titlePost ntc"
"titlePost (setImgPost ntc img) = titlePost ntc"
(* *)
"textPost (setTitlePost ntc title) = textPost ntc"
"textPost (setTextPost ntc text) = text"
"textPost (setImgPost ntc img) = textPost ntc"
(* *)
"imgPost (setTitlePost ntc title) = imgPost ntc"
"imgPost (setTextPost ntc text) = imgPost ntc"
"imgPost (setImgPost ntc img) = img"
by(cases ntc, auto)+

datatype password = Psw String.literal
definition "emptyPass ≡ Psw emptyStr"

(* Information associated to requests for registration: both for users and apps *)
datatype req = ReqInfo String.literal
definition "emptyReq ≡ ReqInfo emptyStr"


subsection ‹Identifiers›

datatype userID = Uid String.literal
datatype postID = Nid String.literal

definition "emptyUserID ≡ Uid emptyStr"
definition "emptyPostID ≡ Nid emptyStr"


(*  *)
fun userIDAsStr where "userIDAsStr (Uid str) = str"

definition "getFreshUserID userIDs ≡ Uid (fresh (set (map userIDAsStr userIDs)) (STR ''2''))"

lemma UserID_userIDAsStr[simp]: "Uid (userIDAsStr userID) = userID"
by (cases userID) auto

lemma member_userIDAsStr_iff[simp]: "str ∈ userIDAsStr ` (set userIDs) ⟷ Uid str ∈∈ userIDs"
by (metis UserID_userIDAsStr image_iff userIDAsStr.simps)

lemma getFreshUserID: "¬ getFreshUserID userIDs ∈∈ userIDs"
using fresh_notIn[of "set (map userIDAsStr userIDs)"] unfolding getFreshUserID_def by auto

(*  *)
fun postIDAsStr where "postIDAsStr (Nid str) = str"

definition "getFreshPostID postIDs ≡ Nid (fresh (set (map postIDAsStr postIDs)) (STR ''3''))"

lemma PostID_postIDAsStr[simp]: "Nid (postIDAsStr postID) = postID"
by (cases postID) auto

lemma member_postIDAsStr_iff[simp]: "str ∈ postIDAsStr ` (set postIDs) ⟷ Nid str ∈∈ postIDs"
by (metis PostID_postIDAsStr image_iff postIDAsStr.simps)

lemma getFreshPostID: "¬ getFreshPostID postIDs ∈∈ postIDs"
using fresh_notIn[of "set (map postIDAsStr postIDs)"] unfolding getFreshPostID_def by auto

end
d>

Theory System_Specification

section ‹System specification›

theory System_Specification
imports Prelim
begin

(* This is the system specification of COSMED.
*)

declare List.insert[simp]

subsection ‹The state›

record state =
  admin :: userID
  (*  *)
  pendingUReqs :: "userID list"
  userReq :: "userID ⇒ req"
  userIDs :: "userID list"
  user :: "userID ⇒ user"
  pass :: "userID ⇒ password"
  (*  *)
  pendingFReqs :: "userID ⇒ userID list"
  friendReq :: "userID ⇒ userID ⇒ req"
  friendIDs :: "userID ⇒ userID list"
  (*  *)
  postIDs :: "postID list"
  post :: "postID ⇒ post"
  owner :: "postID ⇒ userID"
  vis :: "postID ⇒ vis"

definition IDsOK :: "state ⇒ userID list ⇒ postID list ⇒ bool"
where
"IDsOK s uIDs pIDs ≡
 list_all (λ uID. uID ∈∈ userIDs s) uIDs ∧
 list_all (λ pID. pID ∈∈ postIDs s) pIDs"


subsection ‹The actions›

subsubsection‹Initialization of the system›

definition istate :: state
where
"istate ≡
 ⦇
  admin = emptyUserID,

  pendingUReqs = [],
  userReq = (λ uID. emptyReq),
  userIDs = [],
  user = (λ uID. emptyUser),
  pass = (λ uID. emptyPass),

  pendingFReqs = (λ uID. []),
  friendReq = (λ uID uID'. emptyReq),
  friendIDs = (λ uID. []),

  postIDs = [],
  post = (λ papID. emptyPost),
  owner = (λ pID. emptyUserID),
  vis = (λ pID. FriendV)
 ⦈"


subsubsection‹Starting action›

(* This initiates the system. It has the following parameters:
  -- uID, p, name: the admin user id, name and password
*)
definition startSys ::
"state ⇒ userID ⇒ password ⇒ state"
where
"startSys s uID p ≡
 s ⦇admin := uID,
    userIDs := [uID],
    user := (user s) (uID := emptyUser),
    pass := (pass s) (uID := p)⦈"

definition e_startSys :: "state ⇒ userID ⇒ password ⇒  bool"
where
"e_startSys s uID p ≡ userIDs s = []"


subsubsection‹Creation actions›


(* Create new user request: we allow users to choose their own IDs; they could be their email addresses. *)
definition createNUReq :: "state ⇒ userID ⇒ req ⇒ state"
where
"createNUReq s uID reqInfo ≡
 s ⦇pendingUReqs := pendingUReqs s @ [uID],
    userReq := (userReq s)(uID := reqInfo)
⦈"

definition e_createNUReq :: "state ⇒ userID ⇒ req ⇒ bool"
where
"e_createNUReq s uID req ≡
 admin s ∈∈ userIDs s ∧ ¬ uID ∈∈ userIDs s ∧ ¬ uID ∈∈ pendingUReqs s"
(* a new-user request can be created only if the system has started, i.e., if an admin exists *)

(* The admin actually creates a user by approving a pending new-user request.
E.g., the admin can add an  arbitrary password and send it by email to that user.
Then the user can change his password. *)
definition createUser :: "state ⇒ userID ⇒ password ⇒ userID ⇒ password ⇒ state"
where
"createUser s uID p uID' p' ≡
 s ⦇userIDs := uID' # (userIDs s),
    user := (user s) (uID' := emptyUser),
    pass := (pass s) (uID' := p'),
    pendingUReqs := remove1 uID' (pendingUReqs s),
    userReq := (userReq s)(uID := emptyReq)⦈"

definition e_createUser :: "state ⇒ userID ⇒ password ⇒ userID ⇒ password ⇒ bool"
where
"e_createUser s uID p uID' p' ≡
 IDsOK s [uID] [] ∧ pass s uID = p ∧ uID = admin s ∧ uID' ∈∈ pendingUReqs s"


(* Create post: note that post ID is an action parameter, and that the enabledness action
checks that it is fresh.
The web interface will actually generate it, using getFresh. *)
definition createPost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ title ⇒ state"
where
"createPost s uID p pID title ≡
 s ⦇postIDs := pID # postIDs s,
    post := (post s) (pID := Ntc title emptyText emptyImg),
    owner := (owner s) (pID := uID)⦈"
(* Recall from the initial state that the initial visibility is FriendV *)

definition e_createPost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ title ⇒ bool"
where
"e_createPost s uID p pID title ≡
 IDsOK s [uID] [] ∧ pass s uID = p ∧
 ¬ pID ∈∈ postIDs s"

(* Friendship: *)
(* Create friend request, namely uID Reqs friendship of uID': *)
definition createFriendReq :: "state ⇒ userID ⇒ password ⇒ userID ⇒ req ⇒ state"
where
"createFriendReq s uID p uID' req ≡
 let pfr = pendingFReqs s in
 s ⦇pendingFReqs := pfr (uID' := pfr uID' @ [uID]),
    friendReq := fun_upd2 (friendReq s) uID uID' req⦈"

definition e_createFriendReq :: "state ⇒ userID ⇒ password ⇒ userID ⇒ req ⇒ bool"
where
"e_createFriendReq s uID p uID' req ≡
 IDsOK s [uID,uID'] [] ∧ pass s uID = p ∧
 ¬ uID ∈∈ pendingFReqs s uID' ∧ ¬ uID ∈∈ friendIDs s uID'"

(* Create friend, by approving a friend request (namely uID approves the request from uID').
Friendship is symmetric, hence the two updates to "friend";
also, the friendship request is canceled upon approval.  *)
definition createFriend :: "state ⇒ userID ⇒ password ⇒ userID ⇒ state"
where
"createFriend s uID p uID' ≡
 let fr = friendIDs s; pfr = pendingFReqs s in
 s ⦇friendIDs := fr (uID := fr uID @ [uID'], uID' := fr uID' @ [uID]),
    pendingFReqs := pfr (uID := remove1 uID' (pfr uID), uID' := remove1 uID (pfr uID')),
    friendReq := fun_upd2 (fun_upd2 (friendReq s) uID' uID emptyReq) uID uID' emptyReq⦈"

definition e_createFriend :: "state ⇒ userID ⇒ password ⇒ userID ⇒ bool"
where
"e_createFriend s uID p uID' ≡
 IDsOK s [uID,uID'] [] ∧ pass s uID = p ∧
 uID' ∈∈ pendingFReqs s uID"


subsubsection‹Updating actions›

(* Users can update their passwords and names: *)
definition updateUser :: "state ⇒ userID ⇒ password ⇒ password ⇒ name ⇒ inform ⇒ state"
where
"updateUser s uID p p' name info ≡
 s ⦇user := (user s) (uID := Usr name info),
    pass := (pass s) (uID := p')⦈"

definition e_updateUser :: "state ⇒ userID ⇒ password ⇒ password ⇒ name ⇒ inform ⇒ bool"
where
"e_updateUser s uID p p' name info ≡
 IDsOK s [uID] [] ∧ pass s uID = p"


(* Updates of the post components: *)
definition updatePost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ post ⇒ state"
where
"updatePost s uID p pID pst ≡
 s ⦇post := (post s) (pID := pst)⦈"

definition e_updatePost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ post ⇒ bool"
where
"e_updatePost s uID p pID pst ≡
 IDsOK s [uID] [pID] ∧ pass s uID = p ∧
 owner s pID = uID"

definition updateVisPost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ vis ⇒ state"
where
"updateVisPost s uID p pID vs ≡
 s ⦇vis := (vis s) (pID := vs)⦈"

definition e_updateVisPost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ vis ⇒ bool"
where
"e_updateVisPost s uID p pID vs ≡
 IDsOK s [uID] [pID] ∧ pass s uID = p ∧
 owner s pID = uID ∧ vs ∈ {FriendV, PublicV}"



subsubsection‹Deletion (removal) actions›

(* Delete friend:   *)
definition deleteFriend :: "state ⇒ userID ⇒ password ⇒ userID ⇒ state"
where
"deleteFriend s uID p uID' ≡
 let fr = friendIDs s in
 s ⦇friendIDs := fr (uID := removeAll uID' (fr uID), uID' := removeAll uID (fr uID'))⦈"

definition e_deleteFriend :: "state ⇒ userID ⇒ password ⇒ userID ⇒ bool"
where
"e_deleteFriend s uID p uID' ≡
 IDsOK s [uID,uID'] [] ∧ pass s uID = p ∧
 uID' ∈∈ friendIDs s uID"


subsubsection‹Reading actions›

(* Read new user request: *)
definition readNUReq :: "state ⇒ userID ⇒ password ⇒ userID ⇒ req"
where
"readNUReq s uID p uID' ≡ userReq s uID'"

definition e_readNUReq :: "state ⇒ userID ⇒ password ⇒ userID ⇒ bool"
where
"e_readNUReq s uID p uID' ≡
 IDsOK s [uID] [] ∧ pass s uID = p ∧
 uID = admin s ∧ uID' ∈∈ pendingUReqs s"

(* A user can read their name and info (and so can all the other users), but not the password: *)
definition readUser :: "state ⇒ userID ⇒ password ⇒ userID ⇒ name × inform"
where
"readUser s uID p uID' ≡ niUser (user s uID')"

definition e_readUser :: "state ⇒ userID ⇒ password ⇒ userID ⇒ bool"
where
"e_readUser s uID p uID' ≡
 IDsOK s [uID,uID'] [] ∧ pass s uID = p"

(* A user can check if he is the admin: *)
definition readAmIAdmin :: "state ⇒ userID ⇒ password ⇒ bool"
where
"readAmIAdmin s uID p ≡ uID = admin s"

definition e_readAmIAdmin :: "state ⇒ userID ⇒ password ⇒ bool"
where
"e_readAmIAdmin s uID p ≡
 IDsOK s [uID] [] ∧ pass s uID = p"

(* Reading posts: *)
definition readPost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ post"
where
"readPost s uID p pID ≡ post s pID"

definition e_readPost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ bool"
where
"e_readPost s uID p pID ≡
 let post = post s pID in
 IDsOK s [uID] [pID] ∧ pass s uID = p ∧
 (owner s pID = uID ∨ uID ∈∈ friendIDs s (owner s pID) ∨ vis s pID = PublicV)"

definition readVisPost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ vis"
where
"readVisPost s uID p pID ≡ vis s pID"

definition e_readVisPost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ bool"
where
"e_readVisPost s uID p pID ≡
 let post = post s pID in
 IDsOK s [uID] [pID] ∧ pass s uID = p ∧
 (owner s pID = uID ∨ uID ∈∈ friendIDs s (owner s pID) ∨ vis s pID = PublicV)"

definition readOwnerPost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ userID"
where
"readOwnerPost s uID p pID ≡ owner s pID"

definition e_readOwnerPost :: "state ⇒ userID ⇒ password ⇒ postID ⇒ bool"
where
"e_readOwnerPost s uID p pID ≡
 let post = post s pID in
 IDsOK s [uID] [pID] ∧ pass s uID = p ∧
 (owner s pID = uID ∨ uID ∈∈ friendIDs s (owner s pID) ∨ vis s pID = PublicV)"


(* Friendship: *)
(* Read friendship request to me: *)
definition readFriendReqToMe :: "state ⇒ userID ⇒ password ⇒ userID ⇒ req"
where
"readFriendReqToMe s uID p uID' ≡ friendReq s uID' uID"

definition e_readFriendReqToMe :: "state ⇒ userID ⇒ password ⇒ userID ⇒ bool"
where
"e_readFriendReqToMe s uID p uID' ≡
 IDsOK s [uID,uID'] [] ∧ pass s uID = p ∧
 uID' ∈∈ pendingFReqs s uID"

(* Read friendship request from me: *)
definition readFriendReqFromMe :: "state ⇒ userID ⇒ password ⇒ userID ⇒ req"
where
"readFriendReqFromMe s uID p uID' ≡ friendReq s uID uID'"

definition e_readFriendReqFromMe :: "state ⇒ userID ⇒ password ⇒ userID ⇒ bool"
where
"e_readFriendReqFromMe s uID p uID' ≡
 IDsOK s [uID,uID'] [] ∧ pass s uID = p ∧
 uID ∈∈ pendingFReqs s uID'"


subsubsection‹Listing actions›

(* list pending new user requests: *)
definition listPendingUReqs :: "state ⇒ userID ⇒ password ⇒ userID list"
where
"listPendingUReqs s uID p ≡ pendingUReqs s"

definition e_listPendingUReqs :: "state ⇒ userID ⇒ password ⇒ bool"
where
"e_listPendingUReqs s uID p ≡
 IDsOK s [uID] [] ∧ pass s uID = p ∧ uID = admin s"

(* list all users of the system: *)
definition listAllUsers :: "state ⇒ userID ⇒ password ⇒ userID list"
where
"listAllUsers s uID p ≡ userIDs s"

definition e_listAllUsers :: "state ⇒ userID ⇒ password ⇒ bool"
where
"e_listAllUsers s uID p ≡ IDsOK s [uID] [] ∧ pass s uID = p"


(* List a user's friends: *)
definition listFriends :: "state ⇒ userID ⇒ password ⇒ userID ⇒ userID list"
where
"listFriends s uID p uID' ≡ friendIDs s uID'"

definition e_listFriends :: "state ⇒ userID ⇒ password ⇒ userID ⇒ bool"
where
"e_listFriends s uID p uID' ≡
 IDsOK s [uID,uID'] [] ∧ pass s uID = p ∧
 (uID = uID' ∨ uID ∈∈ friendIDs s uID')"

(* list posts:: *)
definition listPosts :: "state ⇒ userID ⇒ password ⇒ (userID × postID) list"
where
"listPosts s uID p ≡
  [(owner s pID, pID).
    pID ← postIDs s,
    vis s pID = PublicV ∨ uID ∈∈ friendIDs s (owner s pID) ∨ uID = owner s pID
  ]"

definition e_listPosts :: "state ⇒ userID ⇒ password ⇒ bool"
where
"e_listPosts s uID p ≡ IDsOK s [uID] [] ∧ pass s uID = p"



subsection‹The step function›

datatype out =
  (* Outputs for creation and update actions, as well as for other actions with errors: *)
  outOK | outErr |
  (* Outputs for reading actions: *)
  outBool bool| outNI "name × inform" | outPost post |
  outImg img | outVis vis | outReq req |
  (* Outputs for listing actions: *)
  outUID "userID" | outUIDL "userID list" |
  outUIDNIDL "(userID × postID)list"
  (* outNone (* Used later for global actions *) *)


(* Start actions (only one, but wrapped for uniformity): *)
datatype sActt =
  sSys userID password

lemmas s_defs =
e_startSys_def startSys_def

fun sStep :: "state ⇒ sActt ⇒ out * state" where
"sStep s (sSys uID p) =
 (if e_startSys s uID p
    then (outOK, startSys s uID p)
    else (outErr, s))"

fun sUserOfA :: "sActt ⇒ userID" where
 "sUserOfA (sSys uID p) = uID"

(* Creation actions: *)
datatype cActt =
  cNUReq userID req
 |cUser userID password userID password
 |cFriendReq userID password userID req
 |cFriend userID password userID
 |cPost userID password postID title

lemmas c_defs =
e_createNUReq_def createNUReq_def
e_createUser_def createUser_def
e_createFriendReq_def createFriendReq_def
e_createFriend_def createFriend_def
e_createPost_def createPost_def

fun cStep :: "state ⇒ cActt ⇒ out * state" where
"cStep s (cNUReq uID req) =
 (if e_createNUReq s uID req
    then (outOK, createNUReq s uID req)
    else (outErr, s))"
|
"cStep s (cUser uID p uID' p') =
 (if e_createUser s uID p uID' p'
    then (outOK, createUser s uID p uID' p')
    else (outErr, s))"
|
"cStep s (cFriendReq uID p uID' req) =
 (if e_createFriendReq s uID p uID' req
    then (outOK, createFriendReq s uID p uID' req)
    else (outErr, s))"
|
"cStep s (cFriend uID p uID') =
 (if e_createFriend s uID p uID'
    then (outOK, createFriend s uID p uID')
    else (outErr, s))"
|
"cStep s (cPost uID p pID title) =
 (if e_createPost s uID p pID title
    then (outOK, createPost s uID p pID title)
    else (outErr, s))"

fun cUserOfA :: "cActt ⇒ userID option" where
 "cUserOfA (cNUReq uID req) = Some uID"
|"cUserOfA (cUser uID p uID' p') = Some uID"
|"cUserOfA (cFriendReq uID p uID' req) = Some uID"
|"cUserOfA (cFriend uID p uID') = Some uID"
|"cUserOfA (cPost uID p pID title) = Some uID"



(* Deletion (removal) actions -- currently only friends can be deleted *)

datatype dActt =
  dFriend userID password userID

lemmas d_defs =
e_deleteFriend_def deleteFriend_def

fun dStep :: "state ⇒ dActt ⇒ out * state" where
"dStep s (dFriend uID p uID') =
 (if e_deleteFriend s uID p uID'
    then (outOK, deleteFriend s uID p uID')
    else (outErr, s))"

fun dUserOfA :: "dActt ⇒ userID" where
 "dUserOfA (dFriend uID p uID') = uID"

(* Update actions: *)
datatype uActt =
  uUser userID password password name inform
 |uPost userID password postID post
 |uVisPost userID password postID vis

lemmas u_defs =
e_updateUser_def updateUser_def
e_updatePost_def updatePost_def
e_updateVisPost_def updateVisPost_def

fun uStep :: "state ⇒ uActt ⇒ out * state" where
"uStep s (uUser uID p p' name info) =
 (if e_updateUser s uID p p' name info
    then (outOK, updateUser s uID p p' name info)
    else (outErr, s))"
|
"uStep s (uPost uID p pID pst) =
 (if e_updatePost s uID p pID pst
    then (outOK, updatePost s uID p pID pst)
    else (outErr, s))"
|
"uStep s (uVisPost uID p pID visStr) =
 (if e_updateVisPost s uID p pID visStr
    then (outOK, updateVisPost s uID p pID visStr)
    else (outErr, s))"

fun uUserOfA :: "uActt ⇒ userID" where
 "uUserOfA (uUser uID p p' name info) = uID"
|"uUserOfA (uPost uID p pID pst) = uID"
|"uUserOfA (uVisPost uID p pID visStr) = uID"


(* Read actions: *)
datatype rActt =
  rNUReq userID password userID
 |rUser userID password userID
 |rAmIAdmin userID password
 |rPost userID password postID
 |rVisPost userID password postID
 |rOwnerPost userID password postID
 |rFriendReqToMe userID password userID
 |rFriendReqFromMe userID password userID

lemmas r_defs =
 readNUReq_def e_readNUReq_def
 readUser_def e_readUser_def
 readAmIAdmin_def e_readAmIAdmin_def
 readPost_def e_readPost_def
 readVisPost_def e_readVisPost_def
 readOwnerPost_def e_readOwnerPost_def
 readFriendReqToMe_def e_readFriendReqToMe_def
 readFriendReqFromMe_def e_readFriendReqFromMe_def

fun rObs :: "state ⇒ rActt ⇒ out" where
"rObs s (rNUReq uID p uID') =
 (if e_readNUReq s uID p uID' then outReq (readNUReq s uID p uID') else outErr)"
|
"rObs s (rUser uID p uID') =
 (if e_readUser s uID p uID' then outNI (readUser s uID p uID') else outErr)"
|
"rObs s (rAmIAdmin uID p) =
 (if e_readAmIAdmin s uID p then outBool (readAmIAdmin s uID p) else outErr)"
|
"rObs s (rPost uID p pID) =
 (if e_readPost s uID p pID then outPost (readPost s uID p pID) else outErr)"
|
"rObs s (rVisPost uID p pID) =
 (if e_readVisPost s uID p pID then outVis (readVisPost s uID p pID) else outErr)"
|
"rObs s (rOwnerPost uID p pID) =
 (if e_readOwnerPost s uID p pID then outUID (readOwnerPost s uID p pID) else outErr)"
|
"rObs s (rFriendReqToMe uID p uID') =
 (if e_readFriendReqToMe s uID p uID' then outReq (readFriendReqToMe s uID p uID') else outErr)"
|
"rObs s (rFriendReqFromMe uID p uID') =
 (if e_readFriendReqFromMe s uID p uID' then outReq (readFriendReqFromMe s uID p uID') else outErr)"


fun rUserOfA :: "rActt ⇒ userID option" where
 "rUserOfA (rNUReq uID p uID') = Some uID"
|"rUserOfA (rUser uID p uID') = Some uID"
|"rUserOfA (rAmIAdmin uID p) = Some uID"
|"rUserOfA (rPost uID p pID) = Some uID"
|"rUserOfA (rVisPost uID p pID) = Some uID"
|"rUserOfA (rOwnerPost uID p pID) = Some uID"
|"rUserOfA (rFriendReqToMe uID p uID') = Some uID"
|"rUserOfA (rFriendReqFromMe uID p uID') = Some uID"


(* Listing actions *)
datatype lActt =
  lPendingUReqs userID password
 |lAllUsers userID password
 |lFriends userID password userID
 |lPosts userID password


lemmas l_defs =
 listPendingUReqs_def e_listPendingUReqs_def
 listAllUsers_def e_listAllUsers_def
 listFriends_def e_listFriends_def
 listPosts_def e_listPosts_def


fun lObs :: "state ⇒ lActt ⇒ out" where
"lObs s (lPendingUReqs uID p) =
 (if e_listPendingUReqs s uID p then outUIDL (listPendingUReqs s uID p) else outErr)"
|
"lObs s (lAllUsers uID p) =
 (if e_listAllUsers s uID p then outUIDL (listAllUsers s uID p) else outErr)"
|
"lObs s (lFriends uID p uID') =
 (if e_listFriends s uID p uID' then outUIDL (listFriends s uID p uID') else outErr)"
|
"lObs s (lPosts uID p) =
 (if e_listPosts s uID p then outUIDNIDL (listPosts s uID p) else outErr)"


fun lUserOfA :: "lActt ⇒ userID option" where
 "lUserOfA (lPendingUReqs uID p) = Some uID"
|"lUserOfA (lAllUsers uID p) = Some uID"
|"lUserOfA (lFriends uID p uID') = Some uID"
|"lUserOfA (lPosts uID p) = Some uID"



(* All actions: *)
datatype act =
  Sact sActt |
(* 3 kinds of effects: creation, deletion and update *)
  Cact cActt | Dact dActt | Uact uActt |
(* 2 kinds of observations: reading and listing (the latter mainly printing IDs) *)
  Ract rActt | Lact lActt


fun step :: "state ⇒ act ⇒ out * state" where
"step s (Sact sa) = sStep s sa"
|
"step s (Cact ca) = cStep s ca"
|
"step s (Dact da) = dStep s da"
|
"step s (Uact ua) = uStep s ua"
|
"step s (Ract ra) = (rObs s ra, s)"
|
"step s (Lact la) = (lObs s la, s)"

fun userOfA :: "act ⇒ userID option" where
"userOfA (Sact sa) = Some (sUserOfA sa)"
|
"userOfA (Cact ca) = cUserOfA ca"
|
"userOfA (Dact da) = Some (dUserOfA da)"
|
"userOfA (Uact ua) = Some (uUserOfA ua)"
|
"userOfA (Ract ra) = rUserOfA ra"
|
"userOfA (Lact la) = lUserOfA la"



subsection ‹Code generation›

export_code step istate getFreshPostID in Scala


end

Theory Automation_Setup

theory Automation_Setup
imports System_Specification
begin

lemma add_prop:
  assumes "PROP (T)"
  shows "A ==> PROP (T)"
  using assms .


lemmas exhaust_elim =
   sActt.exhaust[of x, THEN add_prop[where A="a=Sact x"], rotated -1]
   cActt.exhaust[of x, THEN add_prop[where A="a=Cact x"], rotated -1]
   uActt.exhaust[of x, THEN add_prop[where A="a=Uact x"], rotated -1]
   rActt.exhaust[of x, THEN add_prop[where A="a=Ract x"], rotated -1]
   lActt.exhaust[of x, THEN add_prop[where A="a=Lact x"], rotated -1]
  for x a


lemma state_cong:
fixes s::state
assumes
"pendingUReqs s = pendingUReqs s1 ∧ userReq s = userReq s1 ∧ userIDs s = userIDs s1 ∧
 postIDs s = postIDs s1 ∧ admin s = admin s1 ∧
 user s = user s1 ∧ pass s = pass s1 ∧ pendingFReqs s = pendingFReqs s1 ∧ friendReq s = friendReq s1 ∧ friendIDs s = friendIDs s1 ∧
 post s = post s1 ∧
 owner s = owner s1 ∧
 vis s = vis s1"
shows "s = s1"
using assms by (cases s, cases s1) auto


end

Theory Safety_Properties

section ‹Safety properties›

theory Safety_Properties
imports Automation_Setup "Bounded_Deducibility_Security.Compositional_Reasoning"
begin

interpretation IO_Automaton where
istate = istate and step = step
done

declare if_splits[split]
declare IDsOK_def[simp]

lemmas eff_defs = s_defs c_defs d_defs u_defs
lemmas obs_defs = r_defs l_defs
lemmas all_defs = eff_defs obs_defs
lemmas step_elims = step.elims sStep.elims cStep.elims dStep.elims uStep.elims

declare sstep_Cons[simp]

lemma Lact_Ract_noStateChange[simp]:
assumes "a ∈ Lact ` UNIV ∪ Ract ` UNIV"
shows "snd (step s a) = s"
using assms by (cases a) auto

lemma Lact_Ract_noStateChange_set:
assumes "set al ⊆ Lact ` UNIV ∪ Ract ` UNIV"
shows "snd (sstep s al) = s"
using assms by (induct al) (auto split: prod.splits)

lemma reach_postIDs_persist:
  "pID ∈∈ postIDs s ⟹ step s a = (ou,s') ⟹ pID ∈∈ postIDs s'"
  by (cases a) (auto elim: step_elims simp: eff_defs)

lemma reach_visPost: "reach s ⟹ vis s pID ∈ {FriendV, PublicV}"
proof (induction rule: reach_step_induct)
  case (Step s a)
  then show ?case proof (cases a)
    case (Sact sAct)
    with Step show ?thesis
      by (cases sAct) (auto simp add: s_defs)
  next
    case (Cact cAct)
    with Step show ?thesis
      by (cases cAct) (auto simp add: c_defs)
  next
    case (Dact dAct)
    with Step show ?thesis
      by (cases dAct) (auto simp add: d_defs)
  next
    case (Uact uAct)
    with Step show ?thesis
      by (cases uAct) (auto simp add: u_defs)
  qed auto
qed (auto simp add: istate_def)

lemma reach_owner_userIDs: "reach s ⟹ pID ∈∈ postIDs s ⟹ owner s pID ∈∈ userIDs s"
proof (induction rule: reach_step_induct)
  case (Step s a)
  then show ?case proof (cases a)
    case (Sact sAct)
    with Step show ?thesis
      by (cases sAct) (auto simp add: s_defs)
  next
    case (Cact cAct)
    with Step show ?thesis
      by (cases cAct) (auto simp add: c_defs)
  next
    case (Dact dAct)
    with Step show ?thesis
      by (cases dAct) (auto simp add: d_defs)
  next
    case (Uact uAct)
    with Step show ?thesis
      by (cases uAct) (auto simp add: u_defs)
  qed auto
qed (auto simp add: istate_def)

lemma reach_friendIDs_symmetric:
"reach s ⟹ uID1 ∈∈ friendIDs s uID2 ⟷ uID2 ∈∈ friendIDs s uID1"
proof (induction rule: reach_step_induct)
  case (Step s a) then show ?case proof (cases a)
    case (Sact sAct) with Step show ?thesis by (cases sAct) (auto simp add: s_defs) next
    case (Cact cAct) with Step show ?thesis by (cases cAct) (auto simp add: c_defs ) next
    case (Dact dAct) with Step show ?thesis by (cases dAct) (auto simp add: d_defs ) next
    case (Uact uAct) with Step show ?thesis by (cases uAct) (auto simp add: u_defs)
  qed auto
qed (auto simp add: istate_def)

lemma reach_not_postIDs_vis_FriendV:
assumes  "reach s" "¬ pid ∈∈ postIDs s"
shows "vis s pid = FriendV"
using assms proof (induction rule: reach_step_induct)
  case (Step s a) then show ?case proof (cases a)
    case (Sact sAct) with Step show ?thesis by (cases sAct) (auto simp add: s_defs) next
    case (Cact cAct) with Step show ?thesis by (cases cAct) (auto simp add: c_defs ) next
    case (Dact dAct) with Step show ?thesis by (cases dAct) (auto simp add: d_defs ) next
    case (Uact uAct) with Step show ?thesis by (cases uAct) (auto simp add: u_defs)
  qed auto
qed (auto simp add: istate_def)

lemma reach_distinct_friends_reqs:
assumes "reach s"
shows "distinct (friendIDs s uid)" and "distinct (pendingFReqs s uid)"
  and "uid' ∈∈ pendingFReqs s uid ⟹ uid' ∉ set (friendIDs s uid)"
  and "uid' ∈∈ pendingFReqs s uid ⟹ uid ∉ set (friendIDs s uid')"
using assms proof (induction arbitrary: uid uid' rule: reach_step_induct)
  case Istate
    fix uid uid'
    show "distinct (friendIDs istate uid)" and "distinct (pendingFReqs istate uid)"
     and "uid' ∈∈ pendingFReqs istate uid ⟹ uid' ∉ set (friendIDs istate uid)"
     and "uid' ∈∈ pendingFReqs istate uid ⟹ uid ∉ set (friendIDs istate uid')"
      unfolding istate_def by auto
next
  case (Step s a)
    have s': "reach (snd (step s a))" using reach_step[OF Step(1)] .
    { fix uid uid'
      have "distinct (friendIDs (snd (step s a)) uid) ∧ distinct (pendingFReqs (snd (step s a)) uid)
          ∧ (uid' ∈∈ pendingFReqs (snd (step s a)) uid ⟶ uid' ∉ set (friendIDs (snd (step s a)) uid))"
      proof (cases a)
        case (Sact sa) with Step show ?thesis by (cases sa) (auto simp add: s_defs) next
        case (Cact ca) with Step show ?thesis by (cases ca) (auto simp add: c_defs) next
        case (Dact da) with Step show ?thesis by (cases da) (auto simp add: d_defs distinct_removeAll) next
        case (Uact ua) with Step show ?thesis by (cases ua) (auto simp add: u_defs) next
        case (Ract ra) with Step show ?thesis by auto next
        case (Lact ra) with Step show ?thesis by auto
      qed
    } note goal = this
    fix uid uid'
    from goal show "distinct (friendIDs (snd (step s a)) uid)"
               and "distinct (pendingFReqs (snd (step s a)) uid)" by auto
    assume "uid' ∈∈ pendingFReqs (snd (step s a)) uid"
    with goal show "uid' ∉ set (friendIDs (snd (step s a)) uid)" by auto
    then show "uid ∉ set (friendIDs (snd (step s a)) uid')"
      using reach_friendIDs_symmetric[OF s'] by simp
qed

lemma remove1_in_set: "x ∈∈ remove1 y xs ⟹ x ∈∈ xs"
by (induction xs) auto

lemma reach_IDs_used_IDsOK[rule_format]:
assumes "reach s"
shows "uid ∈∈ pendingFReqs s uid' ⟶ IDsOK s [uid, uid'] []" (is ?p)
and "uid ∈∈ friendIDs s uid' ⟶ IDsOK s [uid, uid'] []" (is ?f)
using assms proof -
  from assms have "uid ∈∈ pendingFReqs s uid' ∨ uid ∈∈ friendIDs s uid'
               ⟶ IDsOK s [uid, uid'] []"
  proof (induction rule: reach_step_induct)
    case Istate then show ?case by (auto simp add: istate_def)
  next
    case (Step s a) then show ?case proof (cases a)
      case (Sact sa) with Step show ?thesis by (cases sa) (auto simp: s_defs) next
      case (Cact ca) with Step show ?thesis by (cases ca) (auto simp: c_defs intro: remove1_in_set) next
      case (Dact da) with Step show ?thesis by (cases da) (auto simp: d_defs) next
      case (Uact ua) with Step show ?thesis by (cases ua) (auto simp: u_defs)
    qed auto
  qed
  then show ?p and ?f by auto
qed

lemma IDs_mono[rule_format]:
assumes "step s a = (ou, s')"
shows "uid ∈∈ userIDs s ⟶ uid ∈∈ userIDs s'" (is "?u")
and "pid ∈∈ postIDs s ⟶ pid ∈∈ postIDs s'" (is "?n")
proof -
  from assms have "?u ∧ ?n" proof (cases a)
    case (Sact sa) with assms show ?thesis by (cases sa) (auto simp add: s_defs) next
    case (Cact ca) with assms show ?thesis by (cases ca) (auto simp add: c_defs) next
    case (Dact da) with assms show ?thesis by (cases da) (auto simp add: d_defs) next
    case (Uact ua) with assms show ?thesis by (cases ua) (auto simp add: u_defs)
  qed (auto)
  then show "?u" "?n" by auto
qed

lemma IDsOK_mono:
assumes "step s a = (ou, s')"
and "IDsOK s uIDs pIDs"
shows "IDsOK s' uIDs pIDs"
using IDs_mono[OF assms(1)] assms(2)
  by (auto simp add: list_all_iff)






end

Theory Observation_Setup

(* The observation functions, the same for all our confidentiality properties *)
theory Observation_Setup
imports Safety_Properties
begin

section‹The observation setup›

text ‹The observers are a arbitrary but fixed set of users:›

consts UIDs :: "userID set"

type_synonym obs = "act * out"

text ‹The observations are all their actions:›

fun γ :: "(state,act,out) trans ⇒ bool" where
"γ (Trans _ a _ _) =
 (userOfA a ∈ Some ` UIDs)"

fun g :: "(state,act,out)trans ⇒ obs" where
"g (Trans _ a ou _) = (a,ou)"


end
>

Theory Post_Intro

theory Post_Intro
  imports "../Safety_Properties" "../Observation_Setup"
begin

section ‹Post confidentiality›

text ‹We prove the following property:

\ \\
Given a group of users ‹UIDs› and a post ‹PID›,

that group cannot learn anything about the different versions of the post ‹PID›
(the initial created version and the later ones obtained by updating the post)

beyond the updates performed while or last before one of the following holds:
\begin{itemize}
\item either a user in ‹UIDs› is the post's owner, a friend of the owner, or the admin
\item or ‹UIDs› has at least one registered user and the post is marked as ``public''.
\end{itemize}
›


end

Theory Post_Value_Setup

(* The value setup for post confidentiality *)
theory Post_Value_Setup
imports Post_Intro
begin

text ‹The ID of the confidential post:›

consts PID :: postID

subsection‹Preliminaries›

(*
(* two posts equal everywhere but w.r.t. their content: *)
fun eqButT :: "post ⇒ post ⇒ bool" where
"eqButT ntc ntc1 =
 (titlePost ntc = titlePost ntc1 ∧
  imgPost ntc = imgPost ntc1 ∧
  visPost ntc = visPost ntc1)"

lemma eqButT_eq[simp,intro!]: "eqButT pap pap"
by(cases pap) auto

lemma eqButT_sym:
assumes "eqButT pap pap1"
shows "eqButT pap1 pap"
apply(cases pap, cases pap1)
using assms by auto

lemma eqButT_trans:
assumes "eqButT pap pap1" and "eqButT pap1 pap2"
shows "eqButT pap pap2"
apply(cases pap, cases pap1, cases pap2)
using assms by auto
*)

(* Auxiliary notion: two functions are equal everywhere but on PID *)
definition eeqButPID where
"eeqButPID ntcs ntcs1 ≡
 ∀ pid. pid ≠ PID ⟶  ntcs pid = ntcs1 pid"

(* ∀ pid. if pid = PID then eqButT (ntcs PID) (ntcs1 PID) else ntcs pid = ntcs1 pid *)

lemmas eeqButPID_intro = eeqButPID_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eeqButPID_eeq[simp,intro!]: "eeqButPID ntcs ntcs"
unfolding eeqButPID_def by auto

lemma eeqButPID_sym:
assumes "eeqButPID ntcs ntcs1" shows "eeqButPID ntcs1 ntcs"
using assms unfolding eeqButPID_def by auto

lemma eeqButPID_trans:
assumes "eeqButPID ntcs ntcs1" and "eeqButPID ntcs1 ntcs2" shows "eeqButPID ntcs ntcs2"
using assms unfolding eeqButPID_def by (auto split: if_splits)

lemma eeqButPID_cong:
assumes "eeqButPID ntcs ntcs1"
and "PID = PID ⟹ eqButT uu uu1"
and "pid ≠ PID ⟹ uu = uu1"
shows "eeqButPID (ntcs (pid := uu)) (ntcs1(pid := uu1))"
using assms unfolding eeqButPID_def by (auto split: if_splits)

(* lemma eeqButPID_eqButT:
"eeqButPID ntcs ntcs1 ⟹ eqButT (ntcs PID) (ntcs1 PID)"
unfolding eeqButPID_def by (auto split: if_splits)
*)

lemma eeqButPID_not_PID:
"⟦eeqButPID ntcs ntcs1; pid ≠ PID⟧ ⟹ ntcs pid = ntcs1 pid"
unfolding eeqButPID_def by (auto split: if_splits)

(*
lemma eeqButPID_postSelectors:
"eeqButPID ntcs ntcs1 ⟹
 visPost (ntcs pid) = visPost (ntcs1 pid)"
  unfolding eeqButPID_def sledgehammer  by (metis eqButT.simps)
*)

lemma eeqButPID_toEq:
assumes "eeqButPID ntcs ntcs1"
shows "ntcs (PID := pst) = ntcs1 (PID := pst)"
using eeqButPID_not_PID[OF assms] by auto

lemma eeqButPID_update_post:
assumes "eeqButPID ntcs ntcs1"
shows "eeqButPID (ntcs (pid := ntc)) (ntcs1 (pid := ntc))"
using eeqButPID_not_PID[OF assms]
using assms unfolding eeqButPID_def by auto

(* The notion of two states being equal everywhere but on the content of
   the post associated to a given PID: *)
definition eqButPID :: "state ⇒ state ⇒ bool" where
"eqButPID s s1 ≡
 admin s = admin s1 ∧

 pendingUReqs s = pendingUReqs s1 ∧ userReq s = userReq s1 ∧
 userIDs s = userIDs s1 ∧ user s = user s1 ∧ pass s = pass s1 ∧

 pendingFReqs s = pendingFReqs s1 ∧ friendReq s = friendReq s1 ∧ friendIDs s = friendIDs s1 ∧

 postIDs s = postIDs s1 ∧ admin s = admin s1 ∧
 eeqButPID (post s) (post s1) ∧
 owner s = owner s1 ∧
 vis s = vis s1"

lemmas eqButPID_intro = eqButPID_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButPID_refl[simp,intro!]: "eqButPID s s"
unfolding eqButPID_def by auto

lemma eqButPID_sym:
assumes "eqButPID s s1" shows "eqButPID s1 s"
using assms eeqButPID_sym unfolding eqButPID_def by auto

lemma eqButPID_trans:
assumes "eqButPID s s1" and "eqButPID s1 s2" shows "eqButPID s s2"
using assms eeqButPID_trans unfolding eqButPID_def
by simp blast

(* Implications from eqButPID, including w.r.t. auxiliary operations: *)
lemma eqButPID_stateSelectors:
"eqButPID s s1 ⟹
 admin s = admin s1 ∧

 pendingUReqs s = pendingUReqs s1 ∧ userReq s = userReq s1 ∧
 userIDs s = userIDs s1 ∧ user s = user s1 ∧ pass s = pass s1 ∧

 pendingFReqs s = pendingFReqs s1 ∧ friendReq s = friendReq s1 ∧ friendIDs s = friendIDs s1 ∧

 postIDs s = postIDs s1 ∧ admin s = admin s1 ∧
 eeqButPID (post s) (post s1) ∧
 owner s = owner s1 ∧
 vis s = vis s1 ∧

 IDsOK s = IDsOK s1"
unfolding eqButPID_def IDsOK_def[abs_def] by auto

(* lemma eqButPID_eqButT:
"eqButPID s s1 ⟹ eqButT (post s PID) (post s1 PID)"
unfolding eqButPID_def using eeqButPID_eqButT by auto *)

lemma eqButPID_not_PID:
"eqButPID s s1 ⟹ pid ≠ PID ⟹ post s pid = post s1 pid"
unfolding eqButPID_def using eeqButPID_not_PID by auto

lemma eqButPID_actions:
assumes "eqButPID s s1"
shows "listPosts s uid p = listPosts s1 uid p"
using eqButPID_stateSelectors[OF assms]
by (auto simp: l_defs intro!: arg_cong2[of _ _ _ _ cmap])

lemma eqButPID_setPost:
assumes "eqButPID s s1"
shows "(post s)(PID := pst) = (post s1)(PID := pst)"
using assms unfolding eqButPID_def using eeqButPID_toEq by auto

lemma eqButPID_update_post:
assumes "eqButPID s s1"
shows "eeqButPID ((post s) (pid := ntc)) ((post s1) (pid := ntc))"
using assms unfolding eqButPID_def using eeqButPID_update_post by auto

lemma eqButPID_cong[simp, intro]:
"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇admin := uu1⦈) (s1 ⦇admin := uu2⦈)"

"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇pendingUReqs := uu1⦈) (s1 ⦇pendingUReqs := uu2⦈)"
"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇userReq := uu1⦈) (s1 ⦇userReq := uu2⦈)"
"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇userIDs := uu1⦈) (s1 ⦇userIDs := uu2⦈)"
"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇user := uu1⦈) (s1 ⦇user := uu2⦈)"
"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇pass := uu1⦈) (s1 ⦇pass := uu2⦈)"

"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇postIDs := uu1⦈) (s1 ⦇postIDs := uu2⦈)"
"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇owner := uu1⦈) (s1 ⦇owner := uu2⦈)"
"⋀ uu1 uu2. eqButPID s s1 ⟹ eeqButPID uu1 uu2 ⟹ eqButPID (s ⦇post := uu1⦈) (s1 ⦇post := uu2⦈)"
"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇vis := uu1⦈) (s1 ⦇vis := uu2⦈)"

"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇pendingFReqs := uu1⦈) (s1 ⦇pendingFReqs := uu2⦈)"
"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇friendReq := uu1⦈) (s1 ⦇friendReq := uu2⦈)"
"⋀ uu1 uu2. eqButPID s s1 ⟹ uu1 = uu2 ⟹ eqButPID (s ⦇friendIDs := uu1⦈) (s1 ⦇friendIDs := uu2⦈)"

unfolding eqButPID_def by auto


subsection‹Value Setup›

datatype "value" =
  TVal post ― ‹updated content of the confidential post›
| OVal bool ― ‹updated dynamic declassification trigger condition›

text ‹Openness of the access window to the confidential information in a given state,
i.e.~the dynamic declassification trigger condition:›

definition openToUIDs where
"openToUIDs s ≡
 ∃ uid ∈ UIDs.
   uid ∈∈ userIDs s ∧
   (uid = owner s PID ∨ uid ∈∈ friendIDs s (owner s PID) ∨
    vis s PID = PublicV)"


definition "open" where "open s ≡ PID ∈∈ postIDs s ∧ openToUIDs s"

lemmas open_defs = openToUIDs_def open_def

lemma eqButPID_openToUIDs:
assumes "eqButPID s s1"
shows "openToUIDs s ⟷ openToUIDs s1"
using eqButPID_stateSelectors[OF assms]
unfolding openToUIDs_def by auto

lemma eqButPID_open:
assumes "eqButPID s s1"
shows "open s ⟷ open s1"
using assms eqButPID_openToUIDs eqButPID_stateSelectors
unfolding open_def by auto

lemma not_open_eqButPID:
assumes 1: "¬ open s" and 2: "eqButPID s s1"
shows "¬ open s1"
using 1 unfolding eqButPID_open[OF 2] .

fun φ :: "(state,act,out) trans ⇒ bool" where
"φ (Trans _ (Uact (uPost uid p pid pst)) ou _) = (pid = PID ∧ ou = outOK)"
|
"φ (Trans s _ _ s') = (open s ≠ open s')"

lemma φ_def2:
  assumes "step s a = (ou,s')"
  shows
    "φ (Trans s a ou s') ⟷
     (∃uid p pst. a = Uact (uPost uid p PID pst) ∧ ou = outOK) ∨
      open s ≠ open s'"
proof (cases a)
  case (Uact ua)
  then show ?thesis
    using assms
    by (cases ua, auto simp: u_defs open_defs)
qed auto

fun f :: "(state,act,out) trans ⇒ value" where
"f (Trans s (Uact (uPost uid p pid pst)) _ s') =
 (if pid = PID then TVal pst else OVal (open s'))"
|
"f (Trans s _ _ s') = OVal (open s')"

lemma Uact_uPost_step_eqButPID:
assumes a: "a = Uact (uPost uid p PID pst)"
and "step s a = (ou,s')"
shows "eqButPID s s'"
using assms unfolding eqButPID_def eeqButPID_def
by (auto simp: u_defs split: if_splits)


(* Key lemma: *)
lemma eqButPID_step:
assumes ss1: "eqButPID s s1"
and step: "step s a = (ou,s')"
and step1: "step s1 a = (ou1,s1')"
shows "eqButPID s' s1'"
proof -
  note [simp] = all_defs
                eeqButPID_def
  note [intro!] = eqButPID_intro
  note * =
    step step1 ss1
    eqButPID_stateSelectors[OF ss1]
    eqButPID_setPost[OF ss1] eqButPID_update_post[OF ss1]
  then show ?thesis
  proof (cases a)
    case (Sact x1)
    then show ?thesis using * by (cases x1) auto
  next
    case (Cact x2)
    then show ?thesis using * by (cases x2) auto
  next
    case (Dact x3)
    then show ?thesis using * by (cases x3) auto
  next
    case (Uact x4)
    show ?thesis
    proof (cases x4)
      case (uUser x11 x12 x13 x14 x15)
      then show ?thesis using Uact * by auto
    next
      case (uPost x31 x32 x33 x34)
      then show ?thesis using Uact * by (cases "x33 = PID") auto
    next
      case (uVisPost x51 x52 x53 x54)
      then show ?thesis using Uact * by (cases "x53 = PID") auto
    qed
  qed auto
qed

lemma eqButPID_step_φ_imp:
assumes ss1: "eqButPID s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and φ: "φ (Trans s a ou s')"
shows "φ (Trans s1 a ou1 s1')"
proof-
  have s's1': "eqButPID s' s1'"
  using eqButPID_step local.step ss1 step1 by blast
  show ?thesis using step step1 φ eqButPID_open[OF ss1] eqButPID_open[OF s's1']
  using eqButPID_stateSelectors[OF ss1]
  unfolding φ_def2[OF step] φ_def2[OF step1]
  by (auto simp: u_defs)
qed

(* Key lemma: *)
lemma eqButPID_step_φ:
assumes s's1': "eqButPID s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
shows "φ (Trans s a ou s') = φ (Trans s1 a ou1 s1')"
by (metis eqButPID_step_φ_imp eqButPID_sym assms)


end
class="head">

Theory Post

theory Post
imports "../Observation_Setup" Post_Value_Setup
begin

subsection ‹Declassification bound›


fun T :: "(state,act,out) trans ⇒ bool" where "T _ = False"

text ‹\label{sec:post-bound}
The bound may dynamically change from closed (‹B›) to open (‹BO›) access to the
confidential information (or vice versa) when the openness predicate changes value.
The bound essentially relates arbitrary value sequences in the closed phase (i.e.~observers
learn nothing about the updates during that phase) and identical value sequences in the open phase
(i.e.~observers may learn everything about the updates during that phase);
when transitioning from a closed to an open access window (‹B_BO› below),
the last update in the closed phase, i.e.~the current version of the post,
is also declassified in addition to subsequent updates.
This formalizes the ``while-or-last-before'' scheme in the informal description of the
confidentiality property.
Moreover, the empty value sequence is treated specially in order to capture harmless cases
where the observers may deduce that no secret updates have occurred,
e.g.~if the system has not been initialized yet.
See @{cite ‹Section 3.4› "cosmed-jar2018"} for a detailed discussion of the bound.›

inductive B :: "value list ⇒ value list ⇒ bool"
and BO :: "value list ⇒ value list ⇒ bool"
where
 B_TVal[simp,intro!]:
  "(pstl = [] ⟶ pstl1 = []) ⟹ B (map TVal pstl) (map TVal pstl1)"
|B_BO[intro]:
  "BO vl vl1 ⟹ (pstl = [] ⟷ pstl1 = []) ⟹ (pstl ≠ [] ⟹ last pstl = last pstl1) ⟹
   B (map TVal pstl  @ OVal True # vl)
     (map TVal pstl1 @ OVal True # vl1)"
(*  *)
|BO_TVal[simp,intro!]:
  "BO (map TVal pstl) (map TVal pstl)"
|BO_B[intro]:
  "B vl vl1 ⟹
   BO (map TVal pstl @ OVal False # vl) (map TVal pstl @ OVal False # vl1)"

lemma B_not_Nil: "B vl vl1 ⟹ vl = [] ⟹ vl1 = []"
by(auto elim: B.cases)

lemma B_OVal_True:
assumes "B (OVal True # vl') vl1"
shows "∃ vl1'. BO vl' vl1' ∧ vl1 = OVal True # vl1'"
using assms apply(auto elim!: B.cases)
by (metis append_self_conv2 hd_append list.map_disc_iff list.map_sel(1) list.sel(1)
       list.sel(3) value.distinct(1))+

no_notation relcomp (infixr "O" 75)

interpretation BD_Security_IO where
istate = istate and step = step and
φ = φ and f = f and γ = γ and g = g and T = T and B = B
done


subsection ‹Unwinding proof›

(* Key lemma: *)
lemma eqButPID_step_γ_out:
assumes ss1: "eqButPID s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and op: "¬ open s"
and sT: "reachNT s" and s1: "reach s1"
and γ: "γ (Trans s a ou s')"
shows "ou = ou1"
proof-
  note [simp] = all_defs
                open_defs
  note s = reachNT_reach[OF sT]
  note willUse =
  step step1 γ
  not_open_eqButPID[OF op ss1]
  reach_visPost[OF s]
  eqButPID_stateSelectors[OF ss1]
  eqButPID_actions[OF ss1]
  eqButPID_not_PID[OF ss1]
  {fix uid p pid assume "a = Ract (rPost uid p pid)"
   hence ?thesis using willUse
   by (cases "pid = PID") fastforce+
  } note intCase1 = this
  show ?thesis
  proof (cases a)
    case (Sact x1)
    then show ?thesis using intCase1 willUse by (cases x1) auto
  next
    case (Cact x2)
    then show ?thesis using intCase1 willUse by (cases x2) auto
  next
    case (Dact x3)
    then show ?thesis using intCase1 willUse by (cases x3) auto
  next
    case (Uact x4)
    then show ?thesis using intCase1 willUse by (cases x4) auto
  next
    case (Ract x5)
    then show ?thesis using intCase1 willUse by (cases x5) auto
  next
    case (Lact x6)
    then show ?thesis using intCase1 willUse by (cases x6) auto
  qed
qed

(* Key lemma: *)
lemma eqButPID_step_eq:
assumes ss1: "eqButPID s s1"
and a: "a = Uact (uPost uid p PID pst)" "ou = outOK"
and step: "step s a = (ou, s')" and step1: "step s1 a = (ou', s1')"
shows "s' = s1'"
using ss1 step step1
using eqButPID_stateSelectors[OF ss1] eqButPID_setPost[OF ss1]
unfolding a by (auto simp: u_defs)

definition Δ0 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ0 s vl s1 vl1 ≡
 ¬ PID ∈∈ postIDs s ∧
 s = s1 ∧ B vl vl1"

definition Δ1 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ1 s vl s1 vl1 ≡
 PID ∈∈ postIDs s ∧
 (∃ pstl pstl1. (pstl = [] ⟶ pstl1 = []) ∧ vl = map TVal pstl ∧ vl1 = map TVal pstl1) ∧
 eqButPID s s1 ∧ ¬ open s"

definition Δ2 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ2 s vl s1 vl1 ≡
 PID ∈∈ postIDs s ∧
 (∃ pstl. vl = map TVal pstl ∧ vl1 = map TVal pstl) ∧
 s = s1 ∧ open s"

definition Δ31 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ31 s vl s1 vl1 ≡
 PID ∈∈ postIDs s ∧
 (∃ pstl pstl1 vll vll1.
    BO vll vll1 ∧ pstl ≠ [] ∧ pstl1 ≠ [] ∧ last pstl = last pstl1 ∧
    vl = map TVal pstl @ OVal True # vll ∧ vl1 = map TVal pstl1 @ OVal True # vll1) ∧
 eqButPID s s1 ∧ ¬ open s"

definition Δ32 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ32 s vl s1 vl1 ≡
 PID ∈∈ postIDs s ∧
 (∃ vll vll1.
    BO vll vll1 ∧
    vl = OVal True # vll ∧ vl1 = OVal True # vll1) ∧
 s = s1 ∧ ¬ open s"

definition Δ4 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ4 s vl s1 vl1 ≡
 PID ∈∈ postIDs s ∧
 (∃ pstl vll vll1.
    B vll vll1 ∧
    vl = map TVal pstl @ OVal False # vll ∧ vl1 = map TVal pstl @ OVal False # vll1) ∧
 s = s1 ∧ open s"

lemma istate_Δ0:
assumes B: "B vl vl1"
shows "Δ0 istate vl istate vl1"
using assms unfolding Δ0_def istate_def by auto

lemma unwind_cont_Δ0: "unwind_cont Δ0 {Δ0,Δ1,Δ2,Δ31,Δ32,Δ4}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ0 s vl s1 vl1 ∨
                           Δ1 s vl s1 vl1 ∨ Δ2 s vl s1 vl1 ∨
                           Δ31 s vl s1 vl1 ∨ Δ32 s vl s1 vl1 ∨ Δ4 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Δ0 s vl s1 vl1"
  hence rs: "reach s" and ss1: "s1 = s" and B: "B vl vl1" and PID: "¬ PID ∈∈ postIDs s"
  using reachNT_reach unfolding Δ0_def by auto
  have vlvl1: "vl = [] ⟹ vl1 = []" using B_not_Nil B by auto
  have op: "¬ open s" using PID unfolding open_defs by auto
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof-
        have ?match proof(cases "∃ uid p text. a = Cact (cPost uid p PID text) ∧ ou = outOK")
          case True
          then obtain uid p "text" where a: "a = Cact (cPost uid p PID text)" and ou: "ou = outOK" by auto
          have PID': "PID ∈∈ postIDs s'"
          using step PID unfolding a ou by (auto simp: c_defs)
          show ?thesis proof(cases "uid ∈ UIDs ∨ (∃ uid' ∈ UIDs. uid' ∈∈ userIDs s ∧ (uid' ∈∈ friendIDs s uid))")
            case True note uid = True
            have op': "open s'" using uid using step PID' unfolding a ou by (auto simp: c_defs open_defs)
            have φ: "φ ?trn" using op op' unfolding φ_def2[OF step] by simp
            then obtain v where vl: "vl = v # vl'" and f: "f ?trn = v"
            using c unfolding consume_def φ_def2 by(cases vl) auto
            have v: "v = OVal True" using f op op' unfolding a by simp
            then obtain vl1' where BO': "BO vl' vl1'" and vl1: "vl1 = OVal True # vl1'"
            using B_OVal_True B unfolding vl v by auto
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 vl1'" using φ f unfolding vl1 v consume_def ss1 by simp
            next
              show "γ ?trn = γ ?trn1" unfolding ss1 by simp
            next
              assume "γ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              show "?Δ s' vl' s' vl1'" using BO' proof(cases rule: BO.cases)
                case (BO_TVal pstl)
                hence "Δ2 s' vl' s' vl1'" using PID' op' unfolding Δ2_def by auto
                thus ?thesis by simp
              next
                case (BO_B vll vll1 pstl)
                hence "Δ4 s' vl' s' vl1'" using PID' op' unfolding Δ4_def by auto
                thus ?thesis by simp
              qed
            qed
          next
            case False note uid = False
            have op': "¬ open s'" using step op uid unfolding open_defs a
              by (auto simp add: c_defs reach_not_postIDs_vis_FriendV rs)
            have φ: "¬ φ ?trn" using op op' a unfolding φ_def2[OF step] by auto
            hence vl': "vl' = vl" using c unfolding consume_def by simp
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 vl1" using φ unfolding consume_def ss1 by auto
            next
              show "γ ?trn = γ ?trn1" unfolding ss1 by simp
            next
              assume "γ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              show "?Δ s' vl' s' vl1" using B proof(cases rule: B.cases)
                case (B_TVal pstl)
                hence "Δ1 s' vl' s' vl1" using PID' op' unfolding Δ1_def vl' by auto
                thus ?thesis by simp
              next
                case (B_BO vll vll1 pstl pstl1)
                show ?thesis
                proof(cases "pstl ≠ [] ∧ pstl1 ≠ []")
                  case True
                  hence "Δ31 s' vl' s' vl1" using B_BO PID' op' unfolding Δ31_def vl' by auto
                  thus ?thesis by simp
                next
                  case False
                  hence "Δ32 s' vl' s' vl1" using B_BO PID' op' unfolding Δ32_def vl' by auto
                  thus ?thesis by simp
                qed
              qed
            qed
          qed
        next
          case False note a = False
          have op': "¬ open s'"
            using a step PID op unfolding open_defs
            by (cases a) (auto elim: step_elims simp: all_defs)
          have φ: "¬ φ ?trn" using PID step op op' unfolding φ_def2[OF step] by (auto simp: u_defs)
          hence vl': "vl' = vl" using c unfolding consume_def by simp
          have PID': "¬ PID ∈∈ postIDs s'"
            using step PID a
            by (cases a) (auto elim: step_elims simp: all_defs)
          show ?thesis proof
            show "validTrans ?trn1" unfolding ss1 using step by simp
          next
            show "consume ?trn1 vl1 vl1" using φ unfolding consume_def ss1 by auto
          next
            show "γ ?trn = γ ?trn1" unfolding ss1 by simp
          next
            assume "γ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
          next
            have "Δ0 s' vl' s' vl1" using a B PID' unfolding Δ0_def vl' by simp
            thus "?Δ s' vl' s' vl1" by simp
          qed
        qed
        thus ?thesis by simp
      qed
    qed
  thus ?thesis using vlvl1 by simp
  qed
qed

lemma unwind_cont_Δ1: "unwind_cont Δ1 {Δ1}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ1 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Δ1 s vl s1 vl1"
  then obtain pstl pstl1 where
  t: "pstl = [] ⟶ pstl1 = []"
  and vl: "vl = map TVal pstl" and vl1: "vl1 = map TVal pstl1"
  and rs: "reach s" and ss1: "eqButPID s s1" and op: "¬ open s" and PID: "PID ∈∈ postIDs s"
  using reachNT_reach unfolding Δ1_def by auto
  have vlvl1: "vl = [] ⟹ vl1 = []" using t unfolding vl vl1 by auto
  have PID1: "PID ∈∈ postIDs s1" using eqButPID_stateSelectors[OF ss1] PID by auto
  have own: "owner s PID ∈ set (userIDs s)" using reach_owner_userIDs[OF rs PID] .
  hence own1: "owner s1 PID ∈ set (userIDs s1)" using eqButPID_stateSelectors[OF ss1] by auto
  have op1: "¬ open s1" using op ss1 eqButPID_open by auto
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof(cases pstl1)
    case (Cons text1 pstll1) note pstl1 = Cons
    define uid where uid: "uid ≡ owner s PID"  define p where p: "p ≡ pass s uid"
    define a1 where a1: "a1 ≡ Uact (uPost uid p PID text1)"
    have uid1: "uid = owner s1 PID" and p1: "p = pass s1 uid" unfolding uid p
    using eqButPID_stateSelectors[OF ss1] by auto
    obtain ou1 s1' where step1: "step s1 a1 = (ou1, s1')" by(cases "step s1 a1") auto
    have ou1: "ou1 = outOK" using step1 PID1 own1 unfolding a1 uid1 p1 by (auto simp: u_defs)
    have op1': "¬ open s1'" using step1 op1 unfolding a1 ou1 open_defs by (auto simp: u_defs)
    have uid: "uid ∉ UIDs" unfolding uid using op PID own unfolding open_defs by auto
    let ?trn1 = "Trans s1 a1 ou1 s1'"
    have ?iact proof
      show "step s1 a1 = (ou1, s1')" using step1 .
    next
      show φ: "φ ?trn1" unfolding φ_def2[OF step1] a1 ou1 by simp
      show "consume ?trn1 vl1 (map TVal pstll1)"
      using φ unfolding vl1 consume_def pstl1 a1 by auto
    next
      show "¬ γ ?trn1" using uid unfolding a1 by auto
    next
      have "eqButPID s1 s1'" using Uact_uPost_step_eqButPID[OF _ step1] a1 by auto
      hence ss1': "eqButPID s s1'" using eqButPID_trans ss1 by blast
      show "?Δ s vl s1' (map TVal pstll1)" using PID op t ss1' unfolding Δ1_def vl pstl1 by auto
    qed
    thus ?thesis by simp
  next
    case Nil note pstl1 = Nil
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID ∈∈ postIDs s'" using reach_postIDs_persist[OF PID step] .
      obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by(cases "step s1 a") auto
      let ?trn1 = "Trans s1 a ou1 s1'"
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof(cases "∃ uid p textt. a = Uact (uPost uid p PID textt) ∧ ou = outOK")
        case True then obtain uid p textt where
        a: "a = Uact (uPost uid p PID textt)" and ou: "ou = outOK" by auto
        hence φ: "φ ?trn" unfolding φ_def2[OF step] by auto
        then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text"
        and vl': "vl' = map TVal pstl'"
        using c unfolding consume_def φ_def2 vl by (cases pstl) auto
        have textt: "textt = text" using f unfolding a by auto
        have uid: "uid ∉ UIDs" using step op PID unfolding a ou open_defs by (auto simp: u_defs)
        have "eqButPID s s'" using Uact_uPost_step_eqButPID[OF a step] by auto
        hence s's1: "eqButPID s' s1" using eqButPID_sym eqButPID_trans ss1 by blast
        have op': "¬ open s'" using step PID' op unfolding a ou open_defs by (auto simp: u_defs)
        have ?ignore proof
          show "¬ γ ?trn" unfolding a using uid by auto
        next
          show "?Δ s' vl' s1 vl1" using PID' s's1 op' unfolding Δ1_def vl' vl1 pstl1 by auto
        qed
        thus ?thesis by simp
      next
        case False note a = False
        {assume φ: "φ ?trn"
         then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text"
         and vl': "vl' = map TVal pstl'" using c unfolding consume_def vl by (cases pstl) auto
         have False using f a φ by (cases ?trn rule: φ.cases) auto
        }
        hence φ: "¬ φ ?trn" by auto
        have op': "¬ open s'" using a op φ unfolding φ_def2[OF step] by auto
        have vl': "vl' = vl" using c φ unfolding consume_def by auto
        have s's1': "eqButPID s' s1'" using eqButPID_step[OF ss1 step step1] .
        have op1': "¬ open s1'" using op' eqButPID_open[OF s's1'] by simp
        have "⋀ uid p text. e_updatePost s1 uid p PID text ⟷ e_updatePost s uid p PID text"
        using eqButPID_stateSelectors[OF ss1] unfolding u_defs by auto
        hence ou1: "⋀ uid p text. a = Uact (uPost uid p PID text) ⟹ ou1 = ou"
        using step step1 by auto
        hence φ1: "¬ φ ?trn1" using a op1 op1' unfolding φ_def2[OF step1] by auto
        have ?match proof
          show "validTrans ?trn1" using step1 by simp
        next
          show "consume ?trn1 vl1 vl1" using φ1 unfolding consume_def by simp
        next
          show "γ ?trn = γ ?trn1" unfolding ss1 by simp
        next
          assume "γ ?trn"
          hence "ou1 = ou" using eqButPID_step_γ_out[OF ss1 step step1 op rsT rs1] by simp
          thus "g ?trn = g ?trn1" by simp
        next
          show "?Δ s' vl' s1' vl1" using s's1' op' PID' unfolding Δ1_def vl' vl vl1 pstl1 by auto
        qed
      thus ?thesis by simp
      qed
    qed
    thus ?thesis using vlvl1 by simp
  qed
qed

lemma unwind_cont_Δ2: "unwind_cont Δ2 {Δ2}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ2 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Δ2 s vl s1 vl1"
  then obtain pstl where
  vl: "vl = map TVal pstl" and vl1: "vl1 = map TVal pstl"
  and rs: "reach s" and ss1: "s1 = s" and op: "open s" and PID: "PID ∈∈ postIDs s"
  using reachNT_reach unfolding Δ2_def by fastforce
  have vlvl1: "vl = [] ⟹ vl1 = []" unfolding vl vl1 by auto
  have own: "owner s PID ∈ set (userIDs s)" using reach_owner_userIDs[OF rs PID] .
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID ∈∈ postIDs s'" using reach_postIDs_persist[OF PID step] .
      {assume op': "¬ open s'"
       hence φ: "φ ?trn" using op unfolding φ_def2[OF step] by simp
       then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text" and vl': "vl' = map TVal pstl'"
       using c unfolding consume_def φ_def2 vl by(cases pstl) auto
       obtain uid p where a: "a = Uact (uPost uid p PID text)" and ou: "ou = outOK"
         using f φ by (cases ?trn rule: φ.cases) auto
       have False using step op op' PID PID' unfolding a ou open_defs by (auto simp: u_defs)
      }
      hence op': "open s'" by auto
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof-
        have ?match proof(cases "φ ?trn")
          case True note φ = True
          then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text" and vl': "vl' = map TVal pstl'"
          using c unfolding consume_def φ_def2 vl by(cases pstl) auto
          obtain uid p textt where a: "a = Uact (uPost uid p PID textt)" and ou: "ou = outOK"
          using φ op op' unfolding φ_def2[OF step] by auto
          have textt: "textt = text" using f unfolding a by simp
          show ?thesis proof
            show "validTrans ?trn1" unfolding ss1 using step by simp
          next
            show "consume ?trn1 vl1 vl'" using φ unfolding ss1 consume_def vl1 vl vl' pstl f by auto
          next
            show "γ ?trn = γ ?trn1" unfolding ss1 by simp
          next
            assume "γ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
          next
            show "?Δ s' vl' s' vl'" using PID' op' unfolding Δ2_def vl1 vl' vl by auto
          qed
        next
          case False note φ = False
          hence vl': "vl' = vl" using c unfolding consume_def by auto
          show ?thesis proof
            show "validTrans ?trn1" unfolding ss1 using step by simp
          next
            show "consume ?trn1 vl1 vl" using φ unfolding ss1 consume_def vl1 vl vl' by auto
          next
            show "γ ?trn = γ ?trn1" unfolding ss1 by simp
          next
            assume "γ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
          next
            show "?Δ s' vl' s' vl" using PID' op' unfolding Δ2_def vl1 vl' vl by auto
          qed
        qed
      thus ?thesis by simp
      qed
    qed
  thus ?thesis using vlvl1 by simp
  qed
qed

lemma unwind_cont_Δ31: "unwind_cont Δ31 {Δ31,Δ32}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ31 s vl s1 vl1 ∨ Δ32 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Δ31 s vl s1 vl1"
  then obtain pstl pstl1 vll vll1 where BO: "BO vll vll1" and
  t: "pstl ≠ []" "pstl1 ≠ []" "last pstl = last pstl1"
  and vl: "vl = map TVal pstl @ OVal True # vll"
  and vl1: "vl1 = map TVal pstl1 @ OVal True # vll1"
  and rs: "reach s" and ss1: "eqButPID s s1" and op: "¬ open s" and PID: "PID ∈∈ postIDs s"
  using reachNT_reach unfolding Δ31_def by auto
  have vlvl1: "vl = [] ⟹ vl1 = []" using t unfolding vl vl1 by auto
  have PID1: "PID ∈∈ postIDs s1" using eqButPID_stateSelectors[OF ss1] PID by auto
  have own: "owner s PID ∈ set (userIDs s)" using reach_owner_userIDs[OF rs PID] .
  hence own1: "owner s1 PID ∈ set (userIDs s1)" using eqButPID_stateSelectors[OF ss1] by auto
  have op1: "¬ open s1" using op ss1 eqButPID_open by auto
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof(cases "length pstl1 ≥ 2" )
    case True then obtain text1 pstll1 where pstl1: "pstl1 = text1 # pstll1"
    and pstll1: "pstll1 ≠ []" by (cases pstl1) fastforce+
    define uid where uid: "uid ≡ owner s PID"  define p where p: "p ≡ pass s uid"
    define a1 where a1: "a1 ≡ Uact (uPost uid p PID text1)"
    have uid1: "uid = owner s1 PID" and p1: "p = pass s1 uid" unfolding uid p
    using eqButPID_stateSelectors[OF ss1] by auto
    obtain ou1 s1' where step1: "step s1 a1 = (ou1, s1')" by(cases "step s1 a1") auto
    have ou1: "ou1 = outOK" using step1 PID1 own1 unfolding a1 uid1 p1 by (auto simp: u_defs)
    have op1': "¬ open s1'" using step1 op1 unfolding a1 ou1 open_defs by (auto simp: u_defs)
    have uid: "uid ∉ UIDs" unfolding uid using op PID own unfolding open_defs by auto
    let ?trn1 = "Trans s1 a1 ou1 s1'"
    have ?iact proof
      show "step s1 a1 = (ou1, s1')" using step1 .
    next
      show φ: "φ ?trn1" unfolding φ_def2[OF step1] a1 ou1 by simp
      show "consume ?trn1 vl1 (map TVal pstll1 @ OVal True # vll1)"
      using φ unfolding vl1 consume_def pstl1 a1 by auto
    next
      show "¬ γ ?trn1" using uid unfolding a1 by auto
    next
      have "eqButPID s1 s1'" using Uact_uPost_step_eqButPID[OF _ step1] a1 by auto
      hence ss1': "eqButPID s s1'" using eqButPID_trans ss1 by blast
      have "Δ31 s vl s1' (map TVal pstll1 @ OVal True # vll1)"
      using BO PID op t ss1' pstll1 unfolding Δ31_def vl pstl1 by auto
      thus "?Δ s vl s1' (map TVal pstll1 @ OVal True # vll1)" by simp
    qed
    thus ?thesis by simp
  next
    case False then obtain text1 where pstl1: "pstl1 = [text1]" using t
    by (cases pstl1) (auto simp: Suc_leI)
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by(cases "step s1 a") auto
      let ?trn1 = "Trans s1 a ou1 s1'"
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof(cases "∃ uid p textt. a = Uact (uPost uid p PID textt) ∧ ou = outOK")
        case True then obtain uid p textt where
        a: "a = Uact (uPost uid p PID textt)" and ou: "ou = outOK" by auto
        hence φ: "φ ?trn" unfolding φ_def2[OF step] by auto
        then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text"
        and vl': "vl' = map TVal pstl' @ OVal True # vll"
        using c t unfolding consume_def φ_def2 vl by (cases pstl) auto
        have textt: "textt = text" using f unfolding a by auto
        have uid: "uid ∉ UIDs" using step op PID unfolding a ou open_defs by (auto simp: u_defs)
        have "eqButPID s s'" using Uact_uPost_step_eqButPID[OF a step] by auto
        hence s's1: "eqButPID s' s1" using eqButPID_sym eqButPID_trans ss1 by blast
        have s's1': "s' = s1'" using step step1 ss1 eqButPID_step_eq unfolding a ou by blast
        have "e_updatePost s' uid p PID textt" using step unfolding a ou by(auto simp: u_defs)
        hence φ1: "φ ?trn1" using step1 unfolding a φ_def2[OF step1] s's1' by auto
        hence f1: "f ?trn1 = TVal text" unfolding a textt by simp
        show ?thesis proof(cases "pstl' = []")
          case True note pstl' = True
          hence pstl: "pstl = [text]" unfolding pstl by auto
          hence text1: "text1 = text" using pstl pstl1 t by auto
          have PID': "PID ∈∈ postIDs s'" using reach_postIDs_persist[OF PID step] .
          have op': "¬ open s'" using step PID' op unfolding a ou open_defs by (auto simp: u_defs)
          have ou1: "ou1 = outOK" using φ1 op1 op' unfolding φ_def2[OF step1] s's1' by auto
          have ?match proof
            show "validTrans ?trn1" using step1 by simp
          next
            show "consume ?trn1 vl1 (OVal True # vll1)"
            using φ1 f1 unfolding consume_def vl1 pstl1 pstl text1 by simp
          next
            show "γ ?trn = γ ?trn1" unfolding ss1 by simp
          next
            assume "γ ?trn"
            show "g ?trn = g ?trn1" using ou ou1 by simp
          next
            have "Δ32 s' vl' s1' (OVal True # vll1)"
            using s's1' BO PID' op' unfolding Δ32_def vl' pstl' by auto
            thus "?Δ s' vl' s1' (OVal True # vll1)" by simp
          qed
          thus ?thesis by simp
        next
          case False note pstl'NE = False
          have lpstl': "last pstl' = text1" using t pstl'NE unfolding pstl pstl1 by simp
          have ?ignore proof
            show "¬ γ ?trn" unfolding a using uid by auto
          next
            have PID': "PID ∈∈ postIDs s'" using reach_postIDs_persist[OF PID step] .
            have op': "¬ open s'" using step PID' op unfolding a ou open_defs by (auto simp: u_defs)
            have ou1: "ou1 = outOK" using φ1 op1 op' unfolding φ_def2[OF step1] s's1' by auto
            have "Δ31 s' vl' s1 vl1"
            using PID' s's1 op' BO pstl'NE lpstl' unfolding Δ31_def vl' vl1 pstl1 by force
            thus "?Δ s' vl' s1 vl1" by simp
          qed
          thus ?thesis by simp
        qed
      next
        case False note a = False
        {assume φ: "φ ?trn"
         then obtain "text" pstl' where pstl: "pstl = text # pstl'" and f: "f ?trn = TVal text"
         and vl': "vl' = map TVal pstl' @ OVal True # vll"
         using c t unfolding consume_def vl by (cases pstl) auto
         have False using f a φ by (cases ?trn rule: φ.cases) auto
        }
        hence φ: "¬ φ ?trn" by auto
        have op': "¬ open s'" using a op φ unfolding φ_def2[OF step] by auto
        have vl': "vl' = vl" using c φ unfolding consume_def by auto
        have s's1': "eqButPID s' s1'" using eqButPID_step[OF ss1 step step1] .
        have op1': "¬ open s1'" using op' eqButPID_open[OF s's1'] by simp
        have "⋀ uid p text. e_updatePost s1 uid p PID text ⟷ e_updatePost s uid p PID text"
        using eqButPID_stateSelectors[OF ss1] unfolding u_defs by auto
        hence ou1: "⋀ uid p text. a = Uact (uPost uid p PID text) ⟹ ou1 = ou"
        using step step1 by auto
        hence φ1: "¬ φ ?trn1" using a op1 op1' unfolding φ_def2[OF step1] by auto
        have ?match proof
          show "validTrans ?trn1" using step1 by simp
        next
          show "consume ?trn1 vl1 vl1" using φ1 unfolding consume_def by simp
        next
          show "γ ?trn = γ ?trn1" unfolding ss1 by simp
        next
          assume "γ ?trn"
          hence "ou1 = ou" using eqButPID_step_γ_out[OF ss1 step step1 op rsT rs1] by simp
          thus "g ?trn = g ?trn1" by simp
        next
          have PID': "PID ∈∈ postIDs s'" using reach_postIDs_persist[OF PID step] .
          have "Δ31 s' vl' s1' vl1" using s's1' op' PID' BO t
          unfolding Δ31_def vl' vl vl1 pstl1 by fastforce
          thus "?Δ s' vl' s1' vl1" by simp
        qed
      thus ?thesis by simp
      qed
    qed
    thus ?thesis using vlvl1 by simp
  qed
qed

lemma unwind_cont_Δ32: "unwind_cont Δ32 {Δ2,Δ32,Δ4}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ2 s vl s1 vl1 ∨ Δ32 s vl s1 vl1 ∨ Δ4 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Δ32 s vl s1 vl1"
  then obtain vll vll1 where BO: "BO vll vll1"
  and vl: "vl = OVal True # vll"
  and vl1: "vl1 = OVal True # vll1"
  and rs: "reach s" and ss1: "s1 = s" and op: "¬ open s" and PID: "PID ∈∈ postIDs s"
  using reachNT_reach unfolding Δ32_def by fastforce
  have vlvl1: "vl = [] ⟹ vl1 = []" unfolding vl vl1 by auto
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID ∈∈ postIDs s'" using reach_postIDs_persist[OF PID step] .
      let ?trn1 = "Trans s1 a ou s'"
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof
        show ?match proof(cases "φ ?trn")
          case True note φ = True
          hence f: "f ?trn = OVal True" and vl': "vl' = vll" using c unfolding consume_def vl by auto
          have op': "open s'" using op φ f unfolding φ_def2[OF step] by auto
          show ?thesis proof
            show "validTrans ?trn1" using step unfolding ss1 by simp
          next
            show "consume ?trn1 vl1 vll1" using φ f unfolding consume_def vl1 ss1 by simp
          next
            show "γ ?trn = γ ?trn1" unfolding ss1 by simp
          next
            assume "γ ?trn"
            thus "g ?trn = g ?trn1" by simp
          next
            show "?Δ s' vl' s' vll1" using BO proof(cases rule: BO.cases)
              case (BO_TVal pstll)
              hence "Δ2 s' vl' s' vll1" using PID' op' unfolding Δ2_def vl' by auto
              thus ?thesis by simp
            next
              case (BO_B vlll pstll)
              hence "Δ4 s' vl' s' vll1" using PID' op' unfolding Δ4_def vl' by auto
              thus ?thesis by simp
            qed
          qed
        next
          case False note φ = False
          hence vl': "vl' = vl" using c unfolding consume_def vl by auto
          have op': "¬ open s'" using op φ unfolding φ_def2[OF step] by auto
          show ?thesis proof
            show "validTrans ?trn1" using step unfolding ss1 by simp
          next
            show "consume ?trn1 vl1 vl1" using φ unfolding consume_def vl1 ss1 by simp
          next
            show "γ ?trn = γ ?trn1" unfolding ss1 by simp
          next
            assume "γ ?trn"
            thus "g ?trn = g ?trn1" by simp
          next
            have "Δ32 s' vl' s' vl1" using BO PID' op' unfolding Δ32_def vl' vl vl1 by simp
            thus "?Δ s' vl' s' vl1" by simp
          qed
        qed
      qed
    qed
  thus ?thesis using vlvl1 by simp
  qed
qed

lemma unwind_cont_Δ4: "unwind_cont Δ4 {Δ1,Δ31,Δ32,Δ4}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ1 s vl s1 vl1 ∨ Δ31 s vl s1 vl1 ∨ Δ32 s vl s1 vl1 ∨ Δ4 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "Δ4 s vl s1 vl1"
  then obtain pstl vll vll1 where B: "B vll vll1"
  and vl: "vl = map TVal pstl @ OVal False # vll" and vl1: "vl1 = map TVal pstl @ OVal False # vll1"
  and rs: "reach s" and ss1: "s1 = s" and op: "open s" and PID: "PID ∈∈ postIDs s"
  using reachNT_reach unfolding Δ4_def by fastforce
  have vlvl1: "vl = [] ⟹ vl1 = []" unfolding vl vl1 by auto
  have own: "owner s PID ∈ set (userIDs s)" using reach_owner_userIDs[OF rs PID] .
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID ∈∈ postIDs s'" using reach_postIDs_persist[OF PID step] .
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof-
        have ?match proof(cases pstl)
          case (Cons "text" pstl') note pstl = Cons
          {assume op': "¬ open s'"
           hence φ: "φ ?trn" using op unfolding φ_def2[OF step] by simp
           hence f: "f ?trn = TVal text"
           and vl': "vl' = map TVal pstl' @ OVal False # vll"
           using c unfolding consume_def vl pstl by auto
           obtain uid p where a: "a = Uact (uPost uid p PID text)" and ou: "ou = outOK"
             using f φ by (cases ?trn rule: φ.cases) auto
           have False using step op op' PID PID' unfolding a ou open_defs by (auto simp: u_defs)
          }
          hence op': "open s'" by auto
          show ?thesis proof(cases "φ ?trn")
            case True note φ = True
            hence f: "f ?trn = TVal text" and vl': "vl' = map TVal pstl' @ OVal False # vll"
            using c unfolding consume_def  vl pstl by auto
            obtain uid p textt where a: "a = Uact (uPost uid p PID textt)" and ou: "ou = outOK"
            using φ op op' unfolding φ_def2[OF step] by auto
            have textt: "textt = text" using f unfolding a by simp
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 (map TVal pstl' @ OVal False # vll1)"
              using φ unfolding ss1 consume_def vl1 vl vl' pstl f by auto
            next
              show "γ ?trn = γ ?trn1" unfolding ss1 by simp
            next
              assume "γ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              have "Δ4 s' vl' s' (map TVal pstl' @ OVal False # vll1)"
              using B PID' op' unfolding Δ4_def vl1 vl' vl by auto
              thus "?Δ s' vl' s' (map TVal pstl' @ OVal False # vll1)" by simp
            qed
          next
            case False note φ = False
            hence vl': "vl' = vl" using c unfolding consume_def by auto
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 vl1" using φ unfolding ss1 consume_def vl1 vl vl' by auto
            next
              show "γ ?trn = γ ?trn1" unfolding ss1 by simp
            next
              assume "γ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              have "Δ4 s' vl' s' vl1"
              using B PID' op' unfolding Δ4_def vl1 vl' vl by auto
              thus "?Δ s' vl' s' vl1" by simp
            qed
          qed
        next
          case Nil note pstl = Nil
          show ?thesis proof(cases "φ ?trn")
            case True note φ = True
            hence f: "f ?trn = OVal False" and vl': "vl' = vll"
            using c unfolding consume_def vl pstl by auto
            hence op': "¬ open s'" using op step φ unfolding φ_def2[OF step] by auto
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 vll1"
              using φ unfolding ss1 consume_def vl1 vl vl' pstl f by auto
            next
              show "γ ?trn = γ ?trn1" unfolding ss1 by simp
            next
              assume "γ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              show "?Δ s' vl' s' vll1" using B proof(cases rule: B.cases)
                case (B_TVal pstlll pstlll1)
                hence "Δ1 s' vl' s' vll1"
                using B PID' op' unfolding Δ1_def vl1 vl' vl by auto
                thus ?thesis by simp
              next
                case (B_BO vlll vlll1 pstlll pstlll1)
                show ?thesis proof(cases "pstlll ≠ [] ∧ pstlll1 ≠ []")
                  case True
                  hence "Δ31 s' vl' s' vll1"
                  using B_BO B PID' op' unfolding Δ31_def vl1 vl' vl by auto
                  thus ?thesis by simp
                next
                  case False
                  hence "Δ32 s' vl' s' vll1"
                  using B_BO B PID' op' unfolding Δ32_def vl1 vl' vl by auto
                  thus ?thesis by simp
                qed
              qed
            qed
          next
            case False note φ = False
            hence vl': "vl' = vl" using c unfolding consume_def by auto
            have op': "open s'" using φ op unfolding φ_def2[OF step] by auto
            show ?thesis proof
              show "validTrans ?trn1" unfolding ss1 using step by simp
            next
              show "consume ?trn1 vl1 vl1" using φ unfolding ss1 consume_def vl1 vl vl' by auto
            next
              show "γ ?trn = γ ?trn1" unfolding ss1 by simp
            next
              assume "γ ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
            next
              have "Δ4 s' vl' s' vl1"
              using B PID' op' unfolding Δ4_def vl1 vl' vl by auto
              thus "?Δ s' vl' s' vl1" by simp
            qed
          qed
        qed
      thus ?thesis by simp
      qed
    qed
  thus ?thesis using vlvl1 by simp
  qed
qed

definition Gr where
"Gr =
 {
 (Δ0, {Δ0,Δ1,Δ2,Δ31,Δ32,Δ4}),
 (Δ1, {Δ1}),
 (Δ2, {Δ2}),
 (Δ31, {Δ31,Δ32}),
 (Δ32, {Δ2,Δ32,Δ4}),
 (Δ4, {Δ1,Δ31,Δ32,Δ4})
 }"


theorem secure: secure
apply (rule unwind_decomp_secure_graph[of Gr Δ0])
unfolding Gr_def
apply (simp, smt insert_subset order_refl)
using
istate_Δ0 unwind_cont_Δ0 unwind_cont_Δ1
unwind_cont_Δ31 unwind_cont_Δ32 unwind_cont_Δ2 unwind_cont_Δ4
unfolding Gr_def by auto




end
dy>

Theory Friend_Intro

theory Friend_Intro
  imports "../Safety_Properties" "../Observation_Setup"
begin

section ‹Friendship status confidentiality›

text ‹We prove the following property:

\ \\
Given a group of users ‹UIDs› and given two users ‹UID1› and ‹UID2› not in that group,

that group cannot learn anything about the changes in the status
of friendship between ‹UID1› and ‹UID2›

beyond what everybody knows, namely that
  ▪ there is no friendship between ‹UID1› and ‹UID2› before those users have been created, and
  ▪ the updates form an alternating sequence of friending and unfriending,

and beyond those updates performed while or last before a user in ‹UIDs› is friends with
‹UID1› or ‹UID2›.›


end

Theory Friend_Value_Setup

(* The value setup for friend confidentiality *)
theory Friend_Value_Setup
imports Friend_Intro
begin

text ‹The confidential information is the friendship status between two arbitrary but fixed users:›

consts UID1 :: userID
consts UID2 :: userID

axiomatization where
UID1_UID2_UIDs: "{UID1,UID2} ∩ UIDs = {}"
and
UID1_UID2: "UID1 ≠ UID2"

subsection ‹Preliminaries›

(* The notion of two userID lists being equal save for at most one occurrence of uid: *)
fun eqButUIDl :: "userID ⇒ userID list ⇒ userID list ⇒ bool" where
"eqButUIDl uid uidl uidl1 = (remove1 uid uidl = remove1 uid uidl1)"

lemma eqButUIDl_eq[simp,intro!]: "eqButUIDl uid uidl uidl"
by auto

lemma eqButUIDl_sym:
assumes "eqButUIDl uid uidl uidl1"
shows "eqButUIDl uid uidl1 uidl"
using assms by auto

lemma eqButUIDl_trans:
assumes "eqButUIDl uid uidl uidl1" and "eqButUIDl uid uidl1 uidl2"
shows "eqButUIDl uid uidl uidl2"
using assms by auto

lemma eqButUIDl_remove1_cong:
assumes "eqButUIDl uid uidl uidl1"
shows "eqButUIDl uid (remove1 uid' uidl) (remove1 uid' uidl1)"
proof -
  have "remove1 uid (remove1 uid' uidl) = remove1 uid' (remove1 uid uidl)" by (simp add: remove1_commute)
  also have "… = remove1 uid' (remove1 uid uidl1)" using assms by simp
  also have "… = remove1 uid (remove1 uid' uidl1)" by (simp add: remove1_commute)
  finally show ?thesis by simp
qed

lemma eqButUIDl_snoc_cong:
assumes "eqButUIDl uid uidl uidl1"
and "uid' ∈∈ uidl ⟷ uid' ∈∈ uidl1"
shows "eqButUIDl uid (uidl ## uid') (uidl1 ## uid')"
using assms by (auto simp add: remove1_append remove1_idem)

(* The notion of two functions each taking a userID and returning a list of user IDs
  being equal everywhere but on UID1 and UID2, where their return results are allowed
  to be eqButUIDl : *)
definition eqButUIDf where
"eqButUIDf frds frds1 ≡
  eqButUIDl UID2 (frds UID1) (frds1 UID1)
∧ eqButUIDl UID1 (frds UID2) (frds1 UID2)
∧ (∀uid. uid ≠ UID1 ∧ uid ≠ UID2 ⟶ frds uid = frds1 uid)"

lemmas eqButUIDf_intro = eqButUIDf_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUIDf_eeq[simp,intro!]: "eqButUIDf frds frds"
unfolding eqButUIDf_def by auto

lemma eqButUIDf_sym:
assumes "eqButUIDf frds frds1" shows "eqButUIDf frds1 frds"
using assms eqButUIDl_sym unfolding eqButUIDf_def
by presburger

lemma eqButUIDf_trans:
assumes "eqButUIDf frds frds1" and "eqButUIDf frds1 frds2"
shows "eqButUIDf frds frds2"
using assms eqButUIDl_trans unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_cong:
assumes "eqButUIDf frds frds1"
and "uid = UID1 ⟹ eqButUIDl UID2 uu uu1"
and "uid = UID2 ⟹ eqButUIDl UID1 uu uu1"
and "uid ≠ UID1 ⟹ uid ≠ UID2 ⟹ uu = uu1"
shows "eqButUIDf (frds (uid := uu)) (frds1(uid := uu1))"
using assms unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_eqButUIDl:
assumes "eqButUIDf frds frds1"
shows "eqButUIDl UID2 (frds UID1) (frds1 UID1)"
  and "eqButUIDl UID1 (frds UID2) (frds1 UID2)"
using assms unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_not_UID:
"⟦eqButUIDf frds frds1; uid ≠ UID1; uid ≠ UID2⟧ ⟹ frds uid = frds1 uid"
unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_not_UID':
assumes eq1: "eqButUIDf frds frds1"
and uid: "(uid,uid') ∉ {(UID1,UID2), (UID2,UID1)}"
shows "uid ∈∈ frds uid' ⟷ uid ∈∈ frds1 uid'"
proof -
  from uid have "(uid' = UID1 ∧ uid ≠ UID2)
               ∨ (uid' = UID2 ∧ uid ≠ UID1)
               ∨ (uid' ∉ {UID1,UID2})" (is "?u1 ∨ ?u2 ∨ ?n12")
    by auto
  then show ?thesis proof (elim disjE)
    assume "?u1"
    moreover then have "uid ∈∈ remove1 UID2 (frds uid') ⟷ uid ∈∈ remove1 UID2 (frds1 uid')"
      using eq1 unfolding eqButUIDf_def by auto
    ultimately show ?thesis by auto
  next
    assume "?u2"
    moreover then have "uid ∈∈ remove1 UID1 (frds uid') ⟷ uid ∈∈ remove1 UID1 (frds1 uid')"
      using eq1 unfolding eqButUIDf_def by auto
    ultimately show ?thesis by auto
  next
    assume "?n12"
    then show ?thesis using eq1 unfolding eqButUIDf_def by auto
  qed
qed

(* The notion of two functions each taking two userID arguments being
  equal everywhere but on the values (UID1,UID2) and (UID2,UID1): *)
definition eqButUID12 where
"eqButUID12 freq freq1 ≡
 ∀ uid uid'. if (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} then True else freq uid uid' = freq1 uid uid'"

lemmas eqButUID12_intro = eqButUID12_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUID12_eeq[simp,intro!]: "eqButUID12 freq freq"
unfolding eqButUID12_def by auto

lemma eqButUID12_sym:
assumes "eqButUID12 freq freq1" shows "eqButUID12 freq1 freq"
using assms unfolding eqButUID12_def
by presburger

lemma eqButUID12_trans:
assumes "eqButUID12 freq freq1" and "eqButUID12 freq1 freq2"
shows "eqButUID12 freq freq2"
using assms unfolding eqButUID12_def by (auto split: if_splits)

lemma eqButUID12_cong:
assumes "eqButUID12 freq freq1"
(*and "uid = UID1 ⟹ eqButUID2 uu uu1"*)
and "¬ (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} ⟹ uu = uu1"
shows "eqButUID12 (fun_upd2 freq uid uid' uu) (fun_upd2 freq1 uid uid' uu1)"
using assms unfolding eqButUID12_def fun_upd2_def by (auto split: if_splits)

lemma eqButUID12_not_UID:
"⟦eqButUID12 freq freq1; ¬ (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}⟧ ⟹ freq uid uid' = freq1 uid uid'"
unfolding eqButUID12_def by (auto split: if_splits)


(* The notion of two states being equal everywhere but on the friendship requests or status of users UID1 and UID2: *)
definition eqButUID :: "state ⇒ state ⇒ bool" where
"eqButUID s s1 ≡
 admin s = admin s1 ∧

 pendingUReqs s = pendingUReqs s1 ∧ userReq s = userReq s1 ∧
 userIDs s = userIDs s1 ∧ user s = user s1 ∧ pass s = pass s1 ∧

 eqButUIDf (pendingFReqs s) (pendingFReqs s1) ∧
 eqButUID12 (friendReq s) (friendReq s1) ∧
 eqButUIDf (friendIDs s) (friendIDs s1) ∧

 postIDs s = postIDs s1 ∧ admin s = admin s1 ∧
 post s = post s1 ∧
 owner s = owner s1 ∧
 vis s = vis s1"

lemmas eqButUID_intro = eqButUID_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUID_refl[simp,intro!]: "eqButUID s s"
unfolding eqButUID_def by auto

lemma eqButUID_sym[sym]:
assumes "eqButUID s s1" shows "eqButUID s1 s"
using assms eqButUIDf_sym eqButUID12_sym unfolding eqButUID_def by auto

lemma eqButUID_trans[trans]:
assumes "eqButUID s s1" and "eqButUID s1 s2" shows "eqButUID s s2"
using assms eqButUIDf_trans eqButUID12_trans unfolding eqButUID_def by metis

(* Implications from eqButUID, including w.r.t. auxiliary operations: *)
lemma eqButUID_stateSelectors:
"eqButUID s s1 ⟹
 admin s = admin s1 ∧

 pendingUReqs s = pendingUReqs s1 ∧ userReq s = userReq s1 ∧
 userIDs s = userIDs s1 ∧ user s = user s1 ∧ pass s = pass s1 ∧

 eqButUIDf (pendingFReqs s) (pendingFReqs s1) ∧
 eqButUID12 (friendReq s) (friendReq s1) ∧
 eqButUIDf (friendIDs s) (friendIDs s1) ∧

 postIDs s = postIDs s1 ∧ admin s = admin s1 ∧
 post s = post s1 ∧
 owner s = owner s1 ∧
 vis s = vis s1 ∧

 IDsOK s = IDsOK s1"
unfolding eqButUID_def IDsOK_def[abs_def] by auto

lemma eqButUID_eqButUID2:
"eqButUID s s1 ⟹ eqButUIDl UID2 (friendIDs s UID1) (friendIDs s1 UID1)"
unfolding eqButUID_def using eqButUIDf_eqButUIDl
by (smt eqButUIDf_eqButUIDl eqButUIDl.simps)

lemma eqButUID_not_UID:
"eqButUID s s1 ⟹ uid ≠ UID ⟹ post s uid = post s1 uid"
unfolding eqButUID_def by auto


lemma eqButUID_cong[simp, intro]:
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇admin := uu1⦈) (s1 ⦇admin := uu2⦈)"

"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇pendingUReqs := uu1⦈) (s1 ⦇pendingUReqs := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇userReq := uu1⦈) (s1 ⦇userReq := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇userIDs := uu1⦈) (s1 ⦇userIDs := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇user := uu1⦈) (s1 ⦇user := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇pass := uu1⦈) (s1 ⦇pass := uu2⦈)"

"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇postIDs := uu1⦈) (s1 ⦇postIDs := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇owner := uu1⦈) (s1 ⦇owner := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇post := uu1⦈) (s1 ⦇post := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇vis := uu1⦈) (s1 ⦇vis := uu2⦈)"

"⋀ uu1 uu2. eqButUID s s1 ⟹ eqButUIDf uu1 uu2 ⟹ eqButUID (s ⦇pendingFReqs := uu1⦈) (s1 ⦇pendingFReqs := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ eqButUID12 uu1 uu2 ⟹ eqButUID (s ⦇friendReq := uu1⦈) (s1 ⦇friendReq := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ eqButUIDf uu1 uu2 ⟹ eqButUID (s ⦇friendIDs := uu1⦈) (s1 ⦇friendIDs := uu2⦈)"

unfolding eqButUID_def by auto

subsection‹Value Setup›

datatype "value" =
  FrVal bool ― ‹updated friendship status between ‹UID1› and ‹UID2››
| OVal bool ― ‹updated dynamic declassification trigger condition›

text ‹The dynamic declassification trigger condition holds, i.e.~the access window to the
confidential information is open, as long as the two users have not been created yet (so there
cannot be friendship between them) or one of them is friends with an observer.›

definition openByA :: "state ⇒ bool" ― ‹Openness by absence›
where "openByA s ≡ ¬ UID1 ∈∈ userIDs s ∨ ¬ UID2 ∈∈ userIDs s"

definition openByF :: "state ⇒ bool" ― ‹Openness by friendship›
where "openByF s ≡ ∃uid ∈ UIDs. uid ∈∈ friendIDs s UID1 ∨ uid ∈∈ friendIDs s UID2"

definition "open" :: "state ⇒ bool"
where "open s ≡ openByA s ∨ openByF s"

lemmas open_defs = open_def openByA_def openByF_def

definition "friends12" :: "state ⇒ bool"
where "friends12 s ≡ UID1 ∈∈ friendIDs s UID2 ∧ UID2 ∈∈ friendIDs s UID1"

fun φ :: "(state,act,out) trans ⇒ bool" where
"φ (Trans s (Cact (cFriend uid p uid')) ou s') =
  ((uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} ∧ ou = outOK ∨
   open s ≠ open s')"
|
"φ (Trans s (Dact (dFriend uid p uid')) ou s') =
  ((uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} ∧ ou = outOK ∨
   open s ≠ open s')"
|
"φ (Trans s (Cact (cUser uid p uid' p')) ou s') =
  (open s ≠ open s')"
|
"φ _ = False"

fun f :: "(state,act,out) trans ⇒ value" where
"f (Trans s (Cact (cFriend uid p uid')) ou s') =
  (if (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} then FrVal True
                                              else OVal True)"
|
"f (Trans s (Dact (dFriend uid p uid')) ou s') =
  (if (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} then FrVal False
                                              else OVal False)"
|
"f (Trans s (Cact (cUser uid p uid' p')) ou s') = OVal False"
|
"f _ = undefined"


lemma φE:
assumes φ: "φ (Trans s a ou s')" (is "φ ?trn")
and step: "step s a = (ou, s')"
and rs: "reach s"
obtains (Friend) uid p uid' where "a = Cact (cFriend uid p uid')" "ou = outOK" "f ?trn = FrVal True"
                                  "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1"
                                  "IDsOK s [UID1, UID2] []"
                                  "¬friends12 s" "friends12 s'"
      | (Unfriend) uid p uid' where "a = Dact (dFriend uid p uid')" "ou = outOK" "f ?trn = FrVal False"
                                    "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1"
                                    "IDsOK s [UID1, UID2] []"
                                    "friends12 s" "¬friends12 s'"
      | (OpenF) uid p uid' where "a = Cact (cFriend uid p uid')"
                                 "(uid ∈ UIDs ∧ uid' ∈ {UID1,UID2}) ∨ (uid' ∈ UIDs ∧ uid ∈ {UID1,UID2})"
                                 "ou = outOK" "f ?trn = OVal True" "¬openByF s" "openByF s'"
                                 "¬openByA s" "¬openByA s'"
      | (CloseF) uid p uid' where "a = Dact (dFriend uid p uid')"
                                  "(uid ∈ UIDs ∧ uid' ∈ {UID1,UID2}) ∨ (uid' ∈ UIDs ∧ uid ∈ {UID1,UID2})"
                                  "ou = outOK" "f ?trn = OVal False" "openByF s" "¬openByF s'"
                                  "¬openByA s" "¬openByA s'"
      | (CloseA) uid p uid' p' where "a = Cact (cUser uid p uid' p')"
                                     "uid' ∈ {UID1,UID2}" "openByA s" "¬openByA s'"
                                     "¬openByF s" "¬openByF s'"
                                     "ou = outOK" "f ?trn = OVal False"
using φ proof (elim φ.elims disjE conjE)
  fix s1 uid p uid' ou1 s1'
  assume "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK"
     and "?trn = Trans s1 (Cact (cFriend uid p uid')) ou1 s1'"
  then have trn: "a = Cact (cFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1"
        and uids: "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1" using UID1_UID2 by auto
  then show thesis using ou uids trn step UID1_UID2_UIDs UID1_UID2 reach_distinct_friends_reqs[OF rs]
    by (intro Friend[of uid p uid']) (auto simp add: c_defs friends12_def)
next
  fix s1 uid p uid' ou1 s1'
  assume op: "open s1 ≠ open s1'"
     and "?trn = Trans s1 (Cact (cFriend uid p uid')) ou1 s1'"
  then have trn: "a = Cact (cFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" by auto
  then have uids: "uid ∈ UIDs ∧ uid' ∈ {UID1, UID2} ∨ uid ∈ {UID1, UID2} ∧ uid' ∈ UIDs" "ou = outOK"
                  "¬openByF s1" "openByF s1'" "¬openByA s1" "¬openByA s1'"
    using op step by (auto simp add: c_defs open_def openByA_def openByF_def)
  then show thesis using op trn step UID1_UID2_UIDs UID1_UID2 by (intro OpenF) auto
next
  fix s1 uid p uid' ou1 s1'
  assume "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK"
     and "?trn = Trans s1 (Dact (dFriend uid p uid')) ou1 s1'"
  then have trn: "a = Dact (dFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1"
        and uids: "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1" using UID1_UID2 by auto
  then show thesis using step ou reach_friendIDs_symmetric[OF rs]
    by (intro Unfriend) (auto simp: d_defs friends12_def)
next
  fix s1 uid p uid' ou1 s1'
  assume op: "open s1 ≠ open s1'"
     and "?trn = Trans s1 (Dact (dFriend uid p uid')) ou1 s1'"
  then have trn: "a = Dact (dFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" by auto
  then have uids: "uid ∈ UIDs ∧ uid' ∈ {UID1, UID2} ∨ uid ∈ {UID1, UID2} ∧ uid' ∈ UIDs" "ou = outOK"
                  "openByF s1" "¬openByF s1'" "¬openByA s1" "¬openByA s1'"
    using op step by (auto simp add: d_defs open_def openByA_def openByF_def)
  then show thesis using op trn step UID1_UID2_UIDs UID1_UID2 by (auto intro: CloseF)
next
  fix s1 uid p uid' p' ou1 s1'
  assume op: "open s1 ≠ open s1'"
     and "?trn = Trans s1 (Cact (cUser uid p uid' p')) ou1 s1'"
  then have trn: "a = Cact (cUser uid p uid' p')" "s = s1" "s' = s1'" "ou = ou1" by auto
  then have uids: "uid' = UID2 ∨ uid' = UID1" "ou = outOK"
                  "¬openByF s1" "¬openByF s1'" "openByA s1" "¬openByA s1'"
    using op step by (auto simp add: c_defs open_def openByF_def openByA_def)
  then show thesis using trn step UID1_UID2_UIDs UID1_UID2 by (intro CloseA) auto
qed

lemma step_open_φ:
assumes "step s a = (ou, s')"
and "open s ≠ open s'"
shows "φ (Trans s a ou s')"
using assms proof (cases a)
  case (Sact sa) then show ?thesis using assms UID1_UID2 by (cases sa) (auto simp: s_defs open_defs) next
  case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs open_defs) next
  case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs open_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs open_defs)
qed auto

lemma step_friends12_φ:
assumes "step s a = (ou, s')"
and "friends12 s ≠ friends12 s'"
shows "φ (Trans s a ou s')"
using assms proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs friends12_def) next
  case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs friends12_def) next
  case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs friends12_def) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs friends12_def)
qed auto

lemma eqButUID_friends12_set_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and f12: "friends12 s = friends12 s1"
and rs: "reach s" and rs1: "reach s1"
shows "set (friendIDs s uid) = set (friendIDs s1 uid)"
proof -
  have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s1 uid)"
    using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto
  from f12 have uid12: "UID1 ∈∈ friendIDs s UID2 ⟷ UID1 ∈∈ friendIDs s1 UID2"
                       "UID2 ∈∈ friendIDs s UID1 ⟷ UID2 ∈∈ friendIDs s1 UID1"
    using reach_friendIDs_symmetric[OF rs] reach_friendIDs_symmetric[OF rs1]
    unfolding friends12_def by auto
  from ss1 have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" unfolding eqButUID_def by simp
  show "set (friendIDs s uid) = set (friendIDs s1 uid)"
  proof (intro equalityI subsetI)
    fix uid'
    assume "uid' ∈∈ friendIDs s uid"
    then show "uid' ∈∈ friendIDs s1 uid"
      using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def
      by (metis (no_types, lifting) insert_iff prod.inject singletonD)
  next
    fix uid'
    assume "uid' ∈∈ friendIDs s1 uid"
    then show "uid' ∈∈ friendIDs s uid"
      using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def
      by (metis (no_types, lifting) insert_iff prod.inject singletonD)
  qed
qed


lemma distinct_remove1_idem: "distinct xs ⟹ remove1 y (remove1 y xs) = remove1 y xs"
by (induction xs) (auto simp add: remove1_idem)

lemma Cact_cFriend_step_eqButUID:
assumes step: "step s (Cact (cFriend uid p uid')) = (ou,s')"
and s: "reach s"
and uids: "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)" (is "?u12 ∨ ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid' ∈∈ pendingFReqs s uid" using step by (auto simp add: c_defs)
  then have fIDs: "uid' ∉ set (friendIDs s uid)" "uid ∉ set (friendIDs s uid')"
        and fRs: "distinct (pendingFReqs s uid)" "distinct (pendingFReqs s uid')"
    using reach_distinct_friends_reqs[OF s] by auto
  have "eqButUIDf (friendIDs s) (friendIDs (createFriend s uid p uid'))"
    using fIDs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append)
  moreover have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriend s uid p uid'))"
    using fRs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs distinct_remove1_idem)
  moreover have "eqButUID12 (friendReq s) (friendReq (createFriend s uid p uid'))"
    using uids unfolding eqButUID12_def
    by (auto simp add: c_defs fun_upd2_eq_but_a_b)
  ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs)
qed (auto)

lemma Cact_cFriendReq_step_eqButUID:
assumes step: "step s (Cact (cFriendReq uid p uid' req)) = (ou,s')"
and uids: "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)" (is "?u12 ∨ ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid ∉ set (pendingFReqs s uid')" "uid ∉ set (friendIDs s uid')"
    using step by (auto simp add: c_defs)
  then have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriendReq s uid p uid' req))"
    using uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append)
  moreover have "eqButUID12 (friendReq s) (friendReq (createFriendReq s uid p uid' req))"
    using uids unfolding eqButUID12_def
    by (auto simp add: c_defs fun_upd2_eq_but_a_b)
  ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs)
qed (auto)


lemma Dact_dFriend_step_eqButUID:
assumes step: "step s (Dact (dFriend uid p uid')) = (ou,s')"
and s: "reach s"
and uids: "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)" (is "?u12 ∨ ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid' ∈∈ friendIDs s uid" using step by (auto simp add: d_defs)
  then have fRs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')"
    using reach_distinct_friends_reqs[OF s] by auto
  have "eqButUIDf (friendIDs s) (friendIDs (deleteFriend s uid p uid'))"
    using fRs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: d_defs remove1_idem distinct_remove1_removeAll)
  then show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: d_defs)
qed (auto)


(* Key lemma: *)
lemma eqButUID_step:
assumes ss1: "eqButUID s s1"
and step: "step s a = (ou,s')"
and step1: "step s1 a = (ou1,s1')"
and rs: "reach s"
and rs1: "reach s1"
shows "eqButUID s' s1'"
proof -
  note simps = eqButUID_def s_defs c_defs u_defs r_defs l_defs
  from assms show ?thesis proof (cases a)
    case (Sact sa) with assms show ?thesis by (cases sa) (auto simp add: simps)
  next
    case (Cact ca) note a = this
      with assms show ?thesis proof (cases ca)
        case (cFriendReq uid p uid' req) note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 unfolding a ca
                by (auto intro: Cact_cFriendReq_step_eqButUID)
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
               and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid ∈∈ pendingFReqs s uid' ⟷ uid ∈∈ pendingFReqs s1 uid'"
                                  "uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'"
                using False by (auto intro!: eqButUIDf_not_UID')
              have "eqButUIDf ((pendingFReqs s)(uid' := pendingFReqs s uid' ## uid))
                              ((pendingFReqs s1)(uid' := pendingFReqs s1 uid' ## uid))"
                using fRs False
                by (intro eqButUIDf_cong) (auto simp add: remove1_append remove1_idem eqButUIDf_def)
              moreover have "eqButUID12 (fun_upd2 (friendReq s) uid uid' req)
                                        (fun_upd2 (friendReq s1) uid uid' req)"
                using ss1 by (intro eqButUID12_cong) (auto simp: simps)
              moreover have "e_createFriendReq s uid p uid' req
                         ⟷ e_createFriendReq s1 uid p uid' req"
                using uid_uid' ss1 by (auto simp: simps)
              ultimately show ?thesis using assms unfolding a ca by (auto simp: simps)
          qed
      next
        case (cFriend uid p uid') note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 rs rs1 unfolding a ca
                by (auto intro!: Cact_cFriend_step_eqButUID)+
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
                    (is "eqButUIDf (?pfr s) (?pfr s1)")
               and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid ∈∈ pendingFReqs s uid' ⟷ uid ∈∈ pendingFReqs s1 uid'"
                                  "uid' ∈∈ pendingFReqs s uid ⟷ uid' ∈∈ pendingFReqs s1 uid"
                                  "uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'"
                                  "uid' ∈∈ friendIDs s uid ⟷ uid' ∈∈ friendIDs s1 uid"
                using False by (auto intro!: eqButUIDf_not_UID')
              have "eqButUIDl UID1 (remove1 uid' (?pfr s UID2)) (remove1 uid' (?pfr s1 UID2))"
               and "eqButUIDl UID2 (remove1 uid' (?pfr s UID1)) (remove1 uid' (?pfr s1 UID1))"
               and "eqButUIDl UID1 (remove1 uid (?pfr s UID2)) (remove1 uid (?pfr s1 UID2))"
               and "eqButUIDl UID2 (remove1 uid (?pfr s UID1)) (remove1 uid (?pfr s1 UID1))"
               using fRs unfolding eqButUIDf_def
               by (auto intro!: eqButUIDl_remove1_cong simp del: eqButUIDl.simps)
              then have 1: "eqButUIDf ((?pfr s)(uid := remove1 uid' (?pfr s uid),
                                                uid' := remove1 uid (?pfr s uid')))
                                     ((?pfr s1)(uid := remove1 uid' (?pfr s1 uid),
                                                uid' := remove1 uid (?pfr s1 uid')))"
                using fRs False
                by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have "uid = UID1 ⟹ eqButUIDl UID2 (friendIDs s UID1 ## uid') (friendIDs s1 UID1 ## uid')"
               and "uid = UID2 ⟹ eqButUIDl UID1 (friendIDs s UID2 ## uid') (friendIDs s1 UID2 ## uid')"
               and "uid' = UID1 ⟹ eqButUIDl UID2 (friendIDs s UID1 ## uid) (friendIDs s1 UID1 ## uid)"
               and "uid' = UID2 ⟹ eqButUIDl UID1 (friendIDs s UID2 ## uid) (friendIDs s1 UID2 ## uid)"
                using fIDs uid_uid' by - (intro eqButUIDl_snoc_cong; simp add: eqButUIDf_def)+
              then have 2: "eqButUIDf ((friendIDs s)(uid := friendIDs s uid ## uid',
                                                      uid' := friendIDs s uid' ## uid))
                                       ((friendIDs s1)(uid := friendIDs s1 uid ## uid',
                                                       uid' := friendIDs s1 uid' ## uid))"
                using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have 3: "eqButUID12 (fun_upd2 (fun_upd2 (friendReq s) uid' uid emptyReq)
                                                                    uid uid' emptyReq)
                                  (fun_upd2 (fun_upd2 (friendReq s1) uid' uid emptyReq)
                                                                     uid uid' emptyReq)"
                using ss1 by (intro eqButUID12_cong) (auto simp: simps)
              have "e_createFriend s uid p uid'
                ⟷ e_createFriend s1 uid p uid'"
                using uid_uid' ss1 by (auto simp: simps)
              with 1 2 3 show ?thesis using assms unfolding a ca by (auto simp: simps)
          qed
      qed (auto simp: simps)
  next
    case (Uact ua) with assms show ?thesis by (cases ua) (auto simp add: simps)
  next
    case (Ract ra) with assms show ?thesis by (cases ra) (auto simp add: simps)
  next
    case (Lact la) with assms show ?thesis by (cases la) (auto simp add: simps)
  next
    case (Dact da) note a = this
      with assms show ?thesis proof (cases da)
        case (dFriend uid p uid') note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 rs rs1 unfolding a ca
                by (auto intro!: Dact_dFriend_step_eqButUID)+
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'"
                                  "uid' ∈∈ friendIDs s uid ⟷ uid' ∈∈ friendIDs s1 uid"
                using False by (auto intro!: eqButUIDf_not_UID')
              have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')"
                          "distinct (friendIDs s1 uid)" "distinct (friendIDs s1 uid')"
                using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto
              have "uid = UID1 ⟹ eqButUIDl UID2 (remove1 uid' (friendIDs s UID1)) (remove1 uid' (friendIDs s1 UID1))"
               and "uid = UID2 ⟹ eqButUIDl UID1 (remove1 uid' (friendIDs s UID2)) (remove1 uid' (friendIDs s1 UID2))"
               and "uid' = UID1 ⟹ eqButUIDl UID2 (remove1 uid (friendIDs s UID1)) (remove1 uid (friendIDs s1 UID1))"
               and "uid' = UID2 ⟹ eqButUIDl UID1 (remove1 uid (friendIDs s UID2)) (remove1 uid (friendIDs s1 UID2))"
                using fIDs uid_uid' by - (intro eqButUIDl_remove1_cong; simp add: eqButUIDf_def)+
              then have 1: "eqButUIDf ((friendIDs s)(uid := remove1 uid' (friendIDs s uid),
                                                      uid' := remove1 uid (friendIDs s uid')))
                                       ((friendIDs s1)(uid := remove1 uid' (friendIDs s1 uid),
                                                       uid' := remove1 uid (friendIDs s1 uid')))"
                using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have "e_deleteFriend s uid p uid'
                ⟷ e_deleteFriend s1 uid p uid'"
                using uid_uid' ss1 by (auto simp: simps d_defs)
              with 1 show ?thesis using assms dfIDs unfolding a ca
                by (auto simp: simps d_defs distinct_remove1_removeAll)
          qed
      qed
  qed
qed

lemma eqButUID_openByA_eq:
assumes "eqButUID s s1"
shows "openByA s = openByA s1"
using assms unfolding openByA_def eqButUID_def by auto

lemma eqButUID_openByF_eq:
assumes ss1: "eqButUID s s1"
shows "openByF s = openByF s1"
proof -
  from ss1 have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" unfolding eqButUID_def by auto
  have "∀uid ∈ UIDs. uid ∈∈ friendIDs s UID1 ⟷ uid ∈∈ friendIDs s1 UID1"
    using UID1_UID2_UIDs UID1_UID2 by (intro ballI eqButUIDf_not_UID'[OF fIDs]; auto)
  moreover have "∀uid ∈ UIDs. uid ∈∈ friendIDs s UID2 ⟷ uid ∈∈ friendIDs s1 UID2"
    using UID1_UID2_UIDs UID1_UID2 by (intro ballI eqButUIDf_not_UID'[OF fIDs]; auto)
  ultimately show "openByF s = openByF s1" unfolding openByF_def by auto
qed

lemma eqButUID_open_eq: "eqButUID s s1 ⟹ open s = open s1"
using eqButUID_openByA_eq eqButUID_openByF_eq unfolding open_def by blast

lemma eqButUID_step_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and a: "a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧ a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
        a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧ a ≠ Dact (dFriend UID2 (pass s UID2) UID1)"
and "friendIDs s = friendIDs s1"
shows "friendIDs s' = friendIDs s1'"
using assms proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs) next
  case (Dact da) then show ?thesis using assms proof (cases da)
    case (dFriend uid p uid')
      with Dact assms show ?thesis
        by (cases "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}")
           (auto simp: d_defs eqButUID_def eqButUIDf_not_UID')
    qed
next
  case (Cact ca) then show ?thesis using assms proof (cases ca)
    case (cFriend uid p uid')
      with Cact assms show ?thesis
        by (cases "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}")
           (auto simp: c_defs eqButUID_def eqButUIDf_not_UID')
    qed (auto simp: c_defs)
qed auto

lemma eqButUID_step_φ_imp:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and a: "a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧ a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
        a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧ a ≠ Dact (dFriend UID2 (pass s UID2) UID1)"
and φ: "φ (Trans s a ou s')"
shows "φ (Trans s1 a ou1 s1')"
proof -
  have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
  then have "open s = open s1" and "open s' = open s1'"
        and "openByA s = openByA s1" and "openByA s' = openByA s1'"
        and "openByF s = openByF s1" and "openByF s' = openByF s1'"
    using ss1 by (auto simp: eqButUID_open_eq eqButUID_openByA_eq eqButUID_openByF_eq)
  with φ a step step1 show "φ (Trans s1 a ou1 s1')" using UID1_UID2_UIDs
    by (elim φ.elims) (auto simp: c_defs d_defs)
qed

(* Key lemma: *)
lemma eqButUID_step_φ:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and a: "a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧ a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
        a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧ a ≠ Dact (dFriend UID2 (pass s UID2) UID1)"
shows "φ (Trans s a ou s') = φ (Trans s1 a ou1 s1')"
proof
  assume "φ (Trans s a ou s')"
  with assms show "φ (Trans s1 a ou1 s1')" by (rule eqButUID_step_φ_imp)
next
  assume "φ (Trans s1 a ou1 s1')"
  moreover have "eqButUID s1 s" using ss1 by (rule eqButUID_sym)
  moreover have "a ≠ Cact (cFriend UID1 (pass s1 UID1) UID2) ∧
                 a ≠ Cact (cFriend UID2 (pass s1 UID2) UID1) ∧
                 a ≠ Dact (dFriend UID1 (pass s1 UID1) UID2) ∧
                 a ≠ Dact (dFriend UID2 (pass s1 UID2) UID1)"
    using a ss1 unfolding eqButUID_def by auto
  ultimately show "φ (Trans s a ou s')" using rs rs1 step step1
    by (intro eqButUID_step_φ_imp[of s1 s])
qed

lemma createFriend_sym: "createFriend s uid p uid' = createFriend s uid' p' uid"
unfolding c_defs by (cases "uid = uid'") (auto simp: fun_upd2_comm fun_upd_twist)

lemma deleteFriend_sym: "deleteFriend s uid p uid' = deleteFriend s uid' p' uid"
unfolding d_defs by (cases "uid = uid'") (auto simp: fun_upd_twist)

lemma createFriendReq_createFriend_absorb:
assumes "e_createFriendReq s uid' p uid req"
shows "createFriend (createFriendReq s uid' p1 uid req) uid p2 uid' = createFriend s uid p3 uid'"
using assms unfolding c_defs by (auto simp: remove1_idem remove1_append fun_upd2_absorb)

lemma eqButUID_deleteFriend12_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
shows "friendIDs (deleteFriend s UID1 p UID2) = friendIDs (deleteFriend s1 UID1 p' UID2)"
proof -
  have "distinct (friendIDs s UID1)" "distinct (friendIDs s UID2)"
       "distinct (friendIDs s1 UID1)" "distinct (friendIDs s1 UID2)"
    using rs rs1 by (auto intro: reach_distinct_friends_reqs)
  then show ?thesis
    using ss1 unfolding eqButUID_def eqButUIDf_def unfolding d_defs
    by (auto simp: distinct_remove1_removeAll)
qed

lemma eqButUID_createFriend12_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and f12: "¬friends12 s" "¬friends12 s1"
shows "friendIDs (createFriend s UID1 p UID2) = friendIDs (createFriend s1 UID1 p' UID2)"
proof -
  have f12': "UID1 ∉ set (friendIDs s UID2)" "UID2 ∉ set (friendIDs s UID1)"
             "UID1 ∉ set (friendIDs s1 UID2)" "UID2 ∉ set (friendIDs s1 UID1)"
    using f12 rs rs1 reach_friendIDs_symmetric unfolding friends12_def by auto
  have "friendIDs s = friendIDs s1"
  proof (intro ext)
    fix uid
    show "friendIDs s uid = friendIDs s1 uid"
      using ss1 f12' unfolding eqButUID_def eqButUIDf_def
      by (cases "uid = UID1 ∨ uid = UID2") (auto simp: remove1_idem)
  qed
  then show ?thesis by (auto simp: c_defs)
qed

end
iv class="head">

Theory Friend

theory Friend
imports "../Observation_Setup" Friend_Value_Setup
begin


subsection ‹Declassification bound›

fun T :: "(state,act,out) trans ⇒ bool"
where "T (Trans _ _ _ _) = False"

text ‹The bound follows the same ``while-or-last-before'' scheme as the bound for post
confidentiality (Section~\ref{sec:post-bound}), alternating between open (‹BO›) and
closed (‹BC›) phases.

The access window is initially open, because the two users are known not to exist when the system
is initialized, so there cannot be friendship between them.

The bound also incorporates the static knowledge that the friendship status alternates between
‹False› and ‹True›.›

fun alternatingFriends :: "value list ⇒ bool ⇒ bool" where
  "alternatingFriends [] _ = True"
| "alternatingFriends (FrVal st # vl) st' ⟷ st' = (¬st) ∧ alternatingFriends vl st"
| "alternatingFriends (OVal _ # vl) st = alternatingFriends vl st"

inductive BO :: "value list ⇒ value list ⇒ bool"
and BC :: "value list ⇒ value list ⇒ bool"
where
 BO_FrVal[simp,intro!]:
  "BO (map FrVal fs) (map FrVal fs)"
|BO_BC[intro]:
  "BC vl vl1 ⟹
   BO (map FrVal fs @ OVal False # vl) (map FrVal fs @ OVal False # vl1)"
(*  *)
|BC_FrVal[simp,intro!]:
  "BC (map FrVal fs) (map FrVal fs1)"
|BC_BO[intro]:
  "BO vl vl1 ⟹ (fs = [] ⟷ fs1 = []) ⟹ (fs ≠ [] ⟹ last fs = last fs1) ⟹
   BC (map FrVal fs  @ OVal True # vl)
      (map FrVal fs1 @ OVal True # vl1)"

definition "B vl vl1 ≡ BO vl vl1 ∧ alternatingFriends vl1 False"


lemma BO_Nil_Nil: "BO vl vl1 ⟹ vl = [] ⟹ vl1 = []"
by (cases rule: BO.cases) auto

no_notation relcomp (infixr "O" 75)

interpretation BD_Security_IO where
istate = istate and step = step and
φ = φ and f = f and γ = γ and g = g and T = T and B = B
done

subsection ‹Unwinding proof›

(* Key lemma: *)
lemma eqButUID_step_γ_out:
assumes ss1: "eqButUID s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and γ: "γ (Trans s a ou s')"
and os: "open s ⟶ friendIDs s = friendIDs s1"
shows "ou = ou1"
proof -
  from γ obtain uid where uid: "userOfA a = Some uid ∧ uid ∈ UIDs ∧ uid ≠ UID1 ∧ uid ≠ UID2
                              ∨ userOfA a = None"
    using UID1_UID2_UIDs  by (cases "userOfA a") auto
  { fix uid
    assume "uid ∈∈ friendIDs s UID1 ∨ uid ∈∈ friendIDs s UID2" and "uid ∈ UIDs"
    with os have "friendIDs s = friendIDs s1" unfolding open_def openByF_def by auto
  } note fIDs = this
  { fix uid uid'
    assume uid: "uid ≠ UID1" "uid ≠ UID2"
    have "friendIDs s uid = friendIDs s1 uid" (is ?f_eq)
     and "pendingFReqs s uid = pendingFReqs s1 uid" (is ?pFR_eq)
     and "uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'" (is ?f_iff)
     and "uid ∈∈ pendingFReqs s uid' ⟷ uid ∈∈ pendingFReqs s1 uid'" (is ?pFR_iff)
     and "friendReq s uid uid' = friendReq s1 uid uid'" (is ?FR_eq)
     and "friendReq s uid' uid = friendReq s1 uid' uid" (is ?FR_eq')
    proof -
      show ?f_eq ?pFR_eq using uid ss1 UID1_UID2_UIDs unfolding eqButUID_def
        by (auto intro!: eqButUIDf_not_UID)
      show ?f_iff ?pFR_iff using uid ss1 UID1_UID2_UIDs unfolding eqButUID_def
        by (auto intro!: eqButUIDf_not_UID')
      from uid have "¬ (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}" by auto
      then show ?FR_eq ?FR_eq' using ss1 UID1_UID2_UIDs unfolding eqButUID_def
        by (auto intro!: eqButUID12_not_UID)
    qed
  } note simps = this eqButUID_def r_defs s_defs c_defs l_defs u_defs d_defs
  note facts = ss1 step step1 uid
  show ?thesis
  proof (cases a)
    case (Ract ra) then show ?thesis using facts by (cases ra) (auto simp add: simps)
  next
    case (Sact sa) then show ?thesis using facts by (cases sa) (auto simp add: simps)
  next
    case (Cact ca) then show ?thesis using facts by (cases ca) (auto simp add: simps)
  next
    case (Lact la)
      then show ?thesis using facts proof (cases la)
        case (lFriends uid p uid')
          with γ have uid: "uid ∈ UIDs" using Lact by auto
          then have uid_uid': "uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'"
            using ss1 UID1_UID2_UIDs unfolding eqButUID_def by (intro eqButUIDf_not_UID') auto
          show ?thesis
          proof (cases "(uid' = UID1 ∨ uid' = UID2) ∧ uid ∈∈ friendIDs s uid'")
            case True
              with uid have "friendIDs s = friendIDs s1" by (intro fIDs) auto
              then show ?thesis using lFriends facts Lact by (auto simp: simps)
          next
            case False
              then show ?thesis using lFriends facts Lact simps(1) uid_uid' by (auto simp: simps)
          qed
      next
        case (lPosts uid p)
          then have o: "⋀PID. owner s PID = owner s1 PID"
                and n: "⋀PID. post s PID = post s1 PID"
                and PIDs: "postIDs s = postIDs s1"
                and viss: "vis s = vis s1"
                and fu: "⋀uid'. uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'"
                and e: "e_listPosts s uid p ⟷ e_listPosts s1 uid p"
            using ss1 uid Lact unfolding eqButUID_def l_defs by (auto simp add: simps(3))
          have "listPosts s uid p = listPosts s1 uid p"
            unfolding listPosts_def o n PIDs fu viss ..
          with e show ?thesis using Lact lPosts step step1 by auto
      qed (auto simp add: simps)
  next
    case (Uact ua) then show ?thesis using facts by (cases ua) (auto simp add: simps)
  next
    case (Dact da) then show ?thesis using facts by (cases da) (auto simp add: simps)
  qed
qed


(* helper *) lemma toggle_friends12_True:
assumes rs: "reach s"
    and IDs: "IDsOK s [UID1, UID2] []"
    and nf12: "¬friends12 s"
obtains al oul
where "sstep s al = (oul, createFriend s UID1 (pass s UID1) UID2)"
  and "al ≠ []" and "eqButUID s (createFriend s UID1 (pass s UID1) UID2)"
  and "friends12 (createFriend s UID1 (pass s UID1) UID2)"
  and "O (traceOf s al) = []" and "V (traceOf s al) = [FrVal True]"
proof cases
  assume "UID1 ∈∈ pendingFReqs s UID2 ∨ UID2 ∈∈ pendingFReqs s UID1"
  then show thesis proof
    assume pFR: "UID1 ∈∈ pendingFReqs s UID2"
    let ?a = "Cact (cFriend UID2 (pass s UID2) UID1)"
    let ?s' = "createFriend s UID1 (pass s UID1) UID2"
    let ?trn = "Trans s ?a outOK ?s'"
    have step: "step s ?a = (outOK, ?s')" using IDs pFR UID1_UID2
      unfolding createFriend_sym[of "s" "UID1" "pass s UID1" "UID2" "pass s UID2"]
      by (auto simp add: c_defs)
    moreover then have "φ ?trn" and "f ?trn = FrVal True" and "friends12 ?s'"
      by (auto simp: c_defs friends12_def)
    moreover have "¬γ ?trn" using UID1_UID2_UIDs by auto
    ultimately show thesis using nf12 rs
      by (intro that[of "[?a]" "[outOK]"]) (auto intro: Cact_cFriend_step_eqButUID)
  next
    assume pFR: "UID2 ∈∈ pendingFReqs s UID1"
    let ?a = "Cact (cFriend UID1 (pass s UID1) UID2)"
    let ?s' = "createFriend s UID1 (pass s UID1) UID2"
    let ?trn = "Trans s ?a outOK ?s'"
    have step: "step s ?a = (outOK, ?s')" using IDs pFR UID1_UID2 by (auto simp add: c_defs)
    moreover then have "φ ?trn" and "f ?trn = FrVal True" and "friends12 ?s'"
      by (auto simp: c_defs friends12_def)
    moreover have "¬γ ?trn" using UID1_UID2_UIDs by auto
    ultimately show thesis using nf12 rs
      by (intro that[of "[?a]" "[outOK]"]) (auto intro: Cact_cFriend_step_eqButUID)
  qed
next
  assume pFR: "¬(UID1 ∈∈ pendingFReqs s UID2 ∨ UID2 ∈∈ pendingFReqs s UID1)"
  let ?a1 = "Cact (cFriendReq UID2 (pass s UID2) UID1 emptyReq)"
  let ?s1 = "createFriendReq s UID2 (pass s UID2) UID1 emptyReq"
  let ?trn1 = "Trans s ?a1 outOK ?s1"
  let ?a2 = "Cact (cFriend UID1 (pass ?s1 UID1) UID2)"
  let ?s2 = "createFriend ?s1 UID1 (pass ?s1 UID1) UID2"
  let ?trn2 = "Trans ?s1 ?a2 outOK ?s2"
  have eFR: "e_createFriendReq s UID2 (pass s UID2) UID1 emptyReq" using IDs pFR nf12
    using reach_friendIDs_symmetric[OF rs]
    by (auto simp add: c_defs friends12_def)
  then have step1: "step s ?a1 = (outOK, ?s1)" by auto
  moreover then have "¬φ ?trn1" and "¬γ ?trn1" using UID1_UID2_UIDs by auto
  moreover have "eqButUID s ?s1" by (intro Cact_cFriendReq_step_eqButUID[OF step1]) auto
  moreover have rs1: "reach ?s1" using step1 by (intro reach_PairI[OF rs])
  moreover have step2: "step ?s1 ?a2 = (outOK, ?s2)" using IDs by (auto simp: c_defs)
  moreover then have "φ ?trn2" and "f ?trn2 = FrVal True" and "friends12 ?s2"
    by (auto simp: c_defs friends12_def)
  moreover have "¬γ ?trn2" using UID1_UID2_UIDs by auto
  moreover have "eqButUID ?s1 ?s2" by (intro Cact_cFriend_step_eqButUID[OF step2 rs1]) auto
  moreover have "?s2 = createFriend s UID1 (pass s UID1) UID2"
    using eFR by (intro createFriendReq_createFriend_absorb)
  ultimately show thesis using nf12 rs
    by (intro that[of "[?a1, ?a2]" "[outOK, outOK]"]) (auto intro: eqButUID_trans)
qed

(* helper *) lemma toggle_friends12_False:
assumes rs: "reach s"
    and IDs: "IDsOK s [UID1, UID2] []"
    and f12: "friends12 s"
obtains al oul
where "sstep s al = (oul, deleteFriend s UID1 (pass s UID1) UID2)"
  and "al ≠ []" and "eqButUID s (deleteFriend s UID1 (pass s UID1) UID2)"
  and "¬friends12 (deleteFriend s UID1 (pass s UID1) UID2)"
  and "O (traceOf s al) = []" and "V (traceOf s al) = [FrVal False]"
proof -
  let ?a = "Dact (dFriend UID1 (pass s UID1) UID2)"
  let ?s' = "deleteFriend s UID1 (pass s UID1) UID2"
  let ?trn = "Trans s ?a outOK ?s'"
  have step: "step s ?a = (outOK, ?s')" using IDs f12 UID1_UID2
    by (auto simp add: d_defs friends12_def)
  moreover then have "φ ?trn" and "f ?trn = FrVal False" and "¬friends12 ?s'"
    using reach_friendIDs_symmetric[OF rs] by (auto simp: d_defs friends12_def)
  moreover have "¬γ ?trn" using UID1_UID2_UIDs by auto
  ultimately show thesis using f12 rs
    by (intro that[of "[?a]" "[outOK]"]) (auto intro: Dact_dFriend_step_eqButUID)
qed


definition Δ0 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ0 s vl s1 vl1 ≡
 eqButUID s s1 ∧ friendIDs s = friendIDs s1 ∧ open s ∧
 BO vl vl1 ∧ alternatingFriends vl1 (friends12 s1)"

definition Δ1 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ1 s vl s1 vl1 ≡ (∃fs fs1.
 eqButUID s s1 ∧ ¬open s ∧
 alternatingFriends vl1 (friends12 s1) ∧
 vl = map FrVal fs ∧ vl1 = map FrVal fs1)"

definition Δ2 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ2 s vl s1 vl1 ≡ (∃fs fs1 vlr vlr1.
 eqButUID s s1 ∧ ¬open s ∧ BO vlr vlr1 ∧
 alternatingFriends vl1 (friends12 s1) ∧
 (fs = [] ⟷ fs1 = []) ∧
 (fs ≠ [] ⟶ last fs = last fs1) ∧
 (fs = [] ⟶ friendIDs s = friendIDs s1) ∧
 vl =  map FrVal fs  @ OVal True # vlr ∧
 vl1 = map FrVal fs1 @ OVal True # vlr1)"

lemma Δ2_I:
assumes "eqButUID s s1" "¬open s" "BO vlr vlr1" "alternatingFriends vl1 (friends12 s1)"
        "fs = [] ⟷ fs1 = []" "fs ≠ [] ⟶ last fs = last fs1"
        "fs = [] ⟶ friendIDs s = friendIDs s1"
        "vl =  map FrVal fs  @ OVal True # vlr"
        "vl1 = map FrVal fs1 @ OVal True # vlr1"
shows "Δ2 s vl s1 vl1"
using assms unfolding Δ2_def by blast


lemma istate_Δ0:
assumes B: "B vl vl1"
shows "Δ0 istate vl istate vl1"
using assms unfolding Δ0_def istate_def B_def open_def openByA_def openByF_def friends12_def
by auto

lemma unwind_cont_Δ0: "unwind_cont Δ0 {Δ0,Δ1,Δ2}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ0 s vl s1 vl1 ∨
                           Δ1 s vl s1 vl1 ∨
                           Δ2 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and Δ0: "Δ0 s vl s1 vl1"
  then have rs: "reach s" and ss1: "eqButUID s s1" and fIDs: "friendIDs s = friendIDs s1"
        and os: "open s" and BO: "BO vl vl1" and aF1: "alternatingFriends vl1 (friends12 s1)"
    using reachNT_reach unfolding Δ0_def by auto
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof cases
        assume φ: "φ ?trn"
        then have vl: "vl = f ?trn # vl'" using c by (auto simp: consume_def)
        from BO have ?match proof (cases "f ?trn")
          case (FrVal fv)
            with BO vl obtain vl1' where vl1': "vl1 = f ?trn # vl1'" and BO': "BO vl' vl1'"
            proof (cases rule: BO.cases)
              case (BO_BC vl'' vl1'' fs)
                moreover with vl FrVal obtain fs' where "fs = fv # fs'" by (cases fs) auto
                ultimately show ?thesis using FrVal BO_BC vl
                  by (intro that[of "map FrVal fs' @ OVal False # vl1''"]) auto
            qed auto
            from fIDs have f12: "friends12 s = friends12 s1" unfolding friends12_def by auto
            show ?match using φ step rs FrVal proof (cases rule: φE)
              case (Friend uid p uid')
                then have IDs1: "IDsOK s1 [UID1, UID2] []"
                  using ss1 unfolding eqButUID_def by auto
                let ?s1' = "createFriend s1 UID1 (pass s1 UID1) UID2"
                have s': "s' = createFriend s UID1 p UID2"
                  using Friend step by (auto simp: createFriend_sym)
                have ss': "eqButUID s s'" using rs step Friend
                  by (auto intro: Cact_cFriend_step_eqButUID)
                moreover then have os': "open s'" using os eqButUID_open_eq by auto
                moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al ≠ []"
                                         and tr1: "O (traceOf s1 al) = []"
                                                  "V (traceOf s1 al) = [FrVal True]"
                                         and f12s1': "friends12 ?s1'"
                                         and s1s1': "eqButUID s1 ?s1'"
                  using rs1 IDs1 Friend unfolding f12 by (auto elim: toggle_friends12_True)
                moreover have "friendIDs s' = friendIDs ?s1'"
                  using Friend(6) f12 unfolding s'
                  by (intro eqButUID_createFriend12_friendIDs_eq[OF ss1 rs rs1]) auto
                ultimately have "Δ0 s' vl' ?s1' vl1'"
                  using ss1 BO' aF1 unfolding Δ0_def vl1' Friend(3)
                  by (auto intro: eqButUID_trans eqButUID_sym)
                moreover have "¬γ ?trn" using Friend UID1_UID2_UIDs by auto
                ultimately show ?match using tr1 vl1' Friend
                  by (intro matchI_ms[OF al]) (auto simp: consumeList_def)
            next
              case (Unfriend uid p uid')
                then have IDs1: "IDsOK s1 [UID1, UID2] []"
                  using ss1 unfolding eqButUID_def by auto
                let ?s1' = "deleteFriend s1 UID1 (pass s1 UID1) UID2"
                have s': "s' = deleteFriend s UID1 p UID2"
                  using Unfriend step by (auto simp: deleteFriend_sym)
                have ss': "eqButUID s s'" using rs step Unfriend
                  by (auto intro: Dact_dFriend_step_eqButUID)
                moreover then have os': "open s'" using os eqButUID_open_eq by auto
                moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al ≠ []"
                                         and tr1: "O (traceOf s1 al) = []"
                                                  "V (traceOf s1 al) = [FrVal False]"
                                         and f12s1': "¬friends12 ?s1'"
                                         and s1s1': "eqButUID s1 ?s1'"
                  using rs1 IDs1 Unfriend unfolding f12 by (auto elim: toggle_friends12_False)
                moreover have "friendIDs s' = friendIDs ?s1'"
                  using fIDs unfolding s' by (auto simp: d_defs)
                ultimately have "Δ0 s' vl' ?s1' vl1'"
                  using ss1 BO' aF1 unfolding Δ0_def vl1' Unfriend(3)
                  by (auto intro: eqButUID_trans eqButUID_sym)
                moreover have "¬γ ?trn" using Unfriend UID1_UID2_UIDs by auto
                ultimately show ?match using tr1 vl1' Unfriend
                  by (intro matchI_ms[OF al]) (auto simp: consumeList_def)
            qed auto
        next
          case (OVal ov)
            with BO vl obtain vl1' where vl1': "vl1 = OVal False # vl1'"
                                      and vl': "vl = OVal False # vl'"
                                      and BC: "BC vl' vl1'"
            proof (cases rule: BO.cases)
              case (BO_BC vl'' vl1'' fs)
                moreover then have "fs = []" using vl unfolding OVal by (cases fs) auto
                ultimately show thesis using vl by (intro that[of vl1'']) auto
            qed auto
            then have "f ?trn = OVal False" using vl by auto
            with φ step rs show ?match proof (cases rule: φE)
              case (CloseF uid p uid')
                let ?s1' = "deleteFriend s1 uid p uid'"
                let ?trn1 = "Trans s1 a outOK ?s1'"
                have s': "s' = deleteFriend s uid p uid'" using CloseF step by auto
                have step1: "step s1 a = (outOK, ?s1')"
                  using CloseF step ss1 fIDs unfolding eqButUID_def by (auto simp: d_defs)
                have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                moreover have os': "¬open s'" using CloseF os unfolding open_def by auto
                moreover have fIDs': "friendIDs s' = friendIDs ?s1'"
                  using fIDs unfolding s' by (auto simp: d_defs)
                moreover have f12s1: "friends12 s1 = friends12 ?s1'"
                  using CloseF(2) UID1_UID2_UIDs unfolding friends12_def d_defs by auto
                from BC have "Δ1 s' vl' ?s1' vl1' ∨ Δ2 s' vl' ?s1' vl1'"
                proof (cases rule: BC.cases)
                  case (BC_FrVal fs fs1)
                    then show ?thesis using aF1 os' fIDs' f12s1 s's1' unfolding Δ1_def vl1' by auto
                next
                  case (BC_BO vlr vlr1 fs fs1)
                    then have "Δ2 s' vl' ?s1' vl1'" using s's1' os' aF1 f12s1 fIDs' unfolding vl1'
                      by (intro Δ2_I[of _ _ _ _ _ fs fs1]) auto
                    then show ?thesis ..
                qed
                moreover have "open s1" "¬open ?s1'"
                  using ss1 os s's1' os' by (auto simp: eqButUID_open_eq)
                moreover then have "φ ?trn1" unfolding CloseF by auto
                ultimately show ?match using step1 vl1' CloseF UID1_UID2 UID1_UID2_UIDs
                  by (intro matchI[of s1 a outOK ?s1' vl1 vl1']) (auto simp: consume_def)
            next
              case (CloseA uid p uid' p')
                let ?s1' = "createUser s1 uid p uid' p'"
                let ?trn1 = "Trans s1 a outOK ?s1'"
                have s': "s' = createUser s uid p uid' p'" using CloseA step by auto
                have step1: "step s1 a = (outOK, ?s1')"
                  using CloseA step ss1 unfolding eqButUID_def by (auto simp: c_defs)
                have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                moreover have os': "¬open s'" using CloseA os unfolding open_def by auto
                moreover have fIDs': "friendIDs s' = friendIDs ?s1'"
                  using fIDs unfolding s' by (auto simp: c_defs)
                moreover have f12s1: "friends12 s1 = friends12 ?s1'"
                  unfolding friends12_def by (auto simp: c_defs)
                from BC have "Δ1 s' vl' ?s1' vl1' ∨ Δ2 s' vl' ?s1' vl1'"
                proof (cases rule: BC.cases)
                  case (BC_FrVal fs fs1)
                    then show ?thesis using aF1 os' fIDs' f12s1 s's1' unfolding Δ1_def vl1' by auto
                next
                  case (BC_BO vlr vlr1 fs fs1)
                    then have "Δ2 s' vl' ?s1' vl1'" using s's1' os' aF1 f12s1 fIDs' unfolding vl1'
                      by (intro Δ2_I[of _ _ _ _ _ fs fs1]) auto
                    then show ?thesis ..
                qed
                moreover have "open s1" "¬open ?s1'"
                  using ss1 os s's1' os' by (auto simp: eqButUID_open_eq)
                moreover then have "φ ?trn1" unfolding CloseA by auto
                ultimately show ?match using step1 vl1' CloseA UID1_UID2 UID1_UID2_UIDs
                  by (intro matchI[of s1 a outOK ?s1' vl1 vl1']) (auto simp: consume_def)
            qed auto
        qed
        then show "?match ∨ ?ignore" ..
      next
        assume nφ: "¬φ ?trn"
        then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'"
          using step_open_φ[OF step] step_friends12_φ[OF step] by auto
        have vl': "vl' = vl" using nφ c by (auto simp: consume_def)
        show ?thesis proof (cases "a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧
                                   a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
                                   a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧
                                   a ≠ Dact (dFriend UID2 (pass s UID2) UID1)")
          case True
            obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto
            let ?trn1 = "Trans s1 a ou1 s1'"
            have fIDs': "friendIDs s' = friendIDs s1'"
              using eqButUID_step_friendIDs_eq[OF ss1 rs rs1 step step1 True fIDs] .
            from True nφ have nφ': "¬φ ?trn1" using eqButUID_step_φ[OF ss1 rs rs1 step step1] by auto
            then have f12s1': "friends12 s1 = friends12 s1'"
              using step_friends12_φ[OF step1] by auto
            have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
            then have "Δ0 s' vl' s1' vl1" using os fIDs' aF1 BO
              unfolding Δ0_def os' f12s1' vl' by auto
            then have ?match
              using step1 nφ' fIDs eqButUID_step_γ_out[OF ss1 step step1]
              by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def)
            then show "?match ∨ ?ignore" ..
        next
          case False
            with nφ have "ou ≠ outOK" by auto
            then have "s' = s" using step False by auto
            then have ?ignore using Δ0 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto
            then show "?match ∨ ?ignore" ..
        qed
      qed
    qed
    then show ?thesis using BO BO_Nil_Nil by auto
  qed
qed

lemma unwind_cont_Δ1: "unwind_cont Δ1 {Δ1, Δ0}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ1 s vl s1 vl1 ∨ Δ0 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and 1: "Δ1 s vl s1 vl1"
  from rsT have rs: "reach s" by (intro reachNT_reach)
  from 1 obtain fs fs1
  where ss1: "eqButUID s s1" and os: "¬open s"
    and aF1: "alternatingFriends vl1 (friends12 s1)"
    and vl: "vl = map FrVal fs" and vl1: "vl1 = map FrVal fs1"
    unfolding Δ1_def by auto
  from os have IDs: "IDsOK s [UID1, UID2] []" unfolding open_defs by auto
  then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof cases
    assume fs1: "fs1 = []"
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof cases
        assume φ: "φ ?trn"
        with vl c obtain fv fs' where vl': "vl' = map FrVal fs'" and fv: "f ?trn = FrVal fv"
          by (cases fs) (auto simp: consume_def)
        from φ step rs fv have ss': "eqButUID s s'"
          by (elim φE) (auto intro: Cact_cFriend_step_eqButUID Dact_dFriend_step_eqButUID)
        then have "¬open s'" using os by (auto simp: eqButUID_open_eq)
        moreover have "eqButUID s' s1" using ss1 ss' by (auto intro: eqButUID_sym eqButUID_trans)
        ultimately have "Δ1 s' vl' s1 vl1" using aF1 unfolding Δ1_def vl' vl1 by auto
        moreover have "¬γ ?trn" using φ step rs fv UID1_UID2_UIDs by (elim φE) auto
        ultimately have ?ignore by (intro ignoreI) auto
        then show "?match ∨ ?ignore" ..
      next
        assume nφ: "¬φ ?trn"
        then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'"
          using step_open_φ[OF step] step_friends12_φ[OF step] by auto
        have vl': "vl' = vl" using nφ c by (auto simp: consume_def)
        show ?thesis proof (cases "a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧
                                   a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
                                   a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧
                                   a ≠ Dact (dFriend UID2 (pass s UID2) UID1)")
          case True
            obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto
            let ?trn1 = "Trans s1 a ou1 s1'"
            from True nφ have nφ': "¬φ ?trn1" using eqButUID_step_φ[OF ss1 rs rs1 step step1] by auto
            then have f12s1': "friends12 s1 = friends12 s1'"
              using step_friends12_φ[OF step1] by auto
            have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
            then have "Δ1 s' vl' s1' vl1" using os aF1 vl vl1
              unfolding Δ1_def os' vl' f12s1' by auto
            then have ?match
              using step1 nφ' os eqButUID_step_γ_out[OF ss1 step step1]
              by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def)
            then show "?match ∨ ?ignore" ..
        next
          case False
            with nφ have "ou ≠ outOK" by auto
            then have "s' = s" using step False by auto
            then have ?ignore using 1 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto
            then show "?match ∨ ?ignore" ..
        qed
      qed
    qed
    then show ?thesis using fs1 unfolding vl1 by auto
  next
    assume "fs1 ≠ []"
    then obtain fs1' where fs1: "fs1 = (¬friends12 s1) # fs1'"
                       and aF1': "alternatingFriends (map FrVal fs1') (¬friends12 s1)"
      using aF1 unfolding vl1 by (cases fs1) auto
    obtain al oul s1' where "sstep s1 al = (oul, s1')" "al ≠ []" "eqButUID s1 s1'"
                            "friends12 s1' = (¬friends12 s1)"
                            "O (traceOf s1 al) = []" "V (traceOf s1 al) = [FrVal (¬friends12 s1)]"
      using rs1 IDs1
      by (cases "friends12 s1") (auto intro: toggle_friends12_True toggle_friends12_False)
    moreover then have "Δ1 s vl s1' (map FrVal fs1')"
      using os aF1' vl ss1 unfolding Δ1_def by (auto intro: eqButUID_sym eqButUID_trans)
    ultimately have ?iact using vl1 unfolding fs1
      by (intro iactionI_ms[of s1 al oul s1'])
         (auto simp: consumeList_def O_Nil_never list_ex_iff_length_V)
    then show ?thesis ..
  qed
qed

lemma unwind_cont_Δ2: "unwind_cont Δ2 {Δ2,Δ0}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ2 s vl s1 vl1 ∨ Δ0 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and 2: "Δ2 s vl s1 vl1"
  from rsT have rs: "reach s" by (intro reachNT_reach)
  obtain fs fs1 vlr vlr1
  where ss1: "eqButUID s s1" and os: "¬open s" and BO: "BO vlr vlr1"
    and aF1: "alternatingFriends vl1 (friends12 s1)"
    and vl:  "vl =  map FrVal fs  @ OVal True # vlr"
    and vl1: "vl1 = map FrVal fs1 @ OVal True # vlr1"
    and fs_fs1: "fs = [] ⟷ fs1 = []"
    and last_fs: "fs ≠ [] ⟶ last fs = last fs1"
    and fs_fIDs: "fs = [] ⟶ friendIDs s = friendIDs s1"
    using 2 unfolding Δ2_def by auto
  from os have IDs: "IDsOK s [UID1, UID2] []" unfolding open_defs by auto
  then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof cases
    assume "length fs1 > 1"
    then obtain fs1'
    where fs1: "fs1 = (¬friends12 s1) # fs1'" and fs1': "fs1' ≠ []"
      and last_fs': "last fs1 = last fs1'"
      and aF1': "alternatingFriends (map FrVal fs1' @ OVal True # vlr1) (¬friends12 s1)"
      using vl1 aF1 by (cases fs1) auto
    obtain al oul s1' where "sstep s1 al = (oul, s1')" "al ≠ []" "eqButUID s1 s1'"
                            "friends12 s1' = (¬friends12 s1)"
                            "O (traceOf s1 al) = []" "V (traceOf s1 al) = [FrVal (¬friends12 s1)]"
      using rs1 IDs1
      by (cases "friends12 s1") (auto intro: toggle_friends12_True toggle_friends12_False)
    moreover then have "Δ2 s vl s1' (map FrVal fs1' @ OVal True # vlr1)"
      using os aF1' vl ss1 fs1' last_fs' fs_fs1 last_fs BO unfolding fs1
      by (intro Δ2_I[of _ _ vlr vlr1 _ fs fs1'])
         (auto intro: eqButUID_sym eqButUID_trans)
    ultimately have ?iact using vl1 unfolding fs1
      by (intro iactionI_ms[of s1 al oul s1'])
         (auto simp: consumeList_def O_Nil_never list_ex_iff_length_V)
    then show ?thesis ..
  next
    assume len1_leq_1: "¬ length fs1 > 1"
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof cases
        assume φ: "φ ?trn"
        show ?thesis proof cases
          assume "length fs > 1"
          then obtain fv fs'
          where fs1: "fs = fv # fs'" and fs1': "fs' ≠ []"
            and last_fs': "last fs = last fs'"
            using vl by (cases fs) auto
          with φ c have fv: "f ?trn = FrVal fv" and vl': "vl' = map FrVal fs' @ OVal True # vlr"
            unfolding vl consume_def by auto
          from φ step rs fv have ss': "eqButUID s s'"
            by (elim φE) (auto intro: Cact_cFriend_step_eqButUID Dact_dFriend_step_eqButUID)
          then have "¬open s'" using os by (auto simp: eqButUID_open_eq)
          moreover have "eqButUID s' s1" using ss1 ss' by (auto intro: eqButUID_sym eqButUID_trans)
          ultimately have "Δ2 s' vl' s1 vl1"
            using aF1 vl' fs1' fs_fs1 last_fs BO unfolding fs1 vl1
            by (intro Δ2_I[of _ _ vlr vlr1 _ fs' fs1])
               (auto intro: eqButUID_sym eqButUID_trans)
          moreover have "¬γ ?trn" using φ step rs fv UID1_UID2_UIDs by (elim φE) auto
          ultimately have ?ignore by (intro ignoreI) auto
          then show "?match ∨ ?ignore" ..
        next
          assume len_leq_1: "¬ length fs > 1"
          show ?thesis proof cases
            assume fs: "fs = []"
            then have fs1: "fs1 = []" and fIDs: "friendIDs s = friendIDs s1"
              using fs_fs1 fs_fIDs by auto
            from fs φ c have ov: "f ?trn = OVal True" and vl': "vl' = vlr"
              unfolding vl consume_def by auto
            with φ step rs have ?match proof (cases rule: φE)
              case (OpenF uid p uid')
                let ?s1' = "createFriend s1 uid p uid'"
                let ?trn1 = "Trans s1 a outOK ?s1'"
                have s': "s' = createFriend s uid p uid'" using OpenF step by auto
                have "eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
                  using ss1 unfolding eqButUID_def by auto
                then have "uid' ∈∈ pendingFReqs s uid ⟷ uid' ∈∈ pendingFReqs s1 uid"
                  using OpenF by (intro eqButUIDf_not_UID') auto
                then have step1: "step s1 a = (outOK, ?s1')"
                  using OpenF step ss1 fIDs unfolding eqButUID_def by (auto simp: c_defs)
                have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                moreover have os': "open s'" using OpenF unfolding open_def by auto
                moreover have fIDs': "friendIDs s' = friendIDs ?s1'"
                  using fIDs unfolding s' by (auto simp: c_defs)
                moreover have f12s1: "friends12 s1 = friends12 ?s1'"
                  using OpenF(2) UID1_UID2_UIDs unfolding friends12_def c_defs by auto
                ultimately have "Δ0 s' vl' ?s1' vlr1"
                  using BO aF1 unfolding Δ0_def vl' vl1 fs1 by auto
                moreover have "¬open s1" "open ?s1'"
                  using ss1 os s's1' os' by (auto simp: eqButUID_open_eq)
                moreover then have "φ ?trn1" unfolding OpenF by auto
                ultimately show ?match using step1 vl1 fs1 OpenF UID1_UID2 UID1_UID2_UIDs
                  by (intro matchI[of s1 a outOK ?s1' vl1 vlr1]) (auto simp: consume_def)
            qed auto
            then show ?thesis ..
          next
            assume "fs ≠ []"
            then obtain fv where fs: "fs = [fv]" using len_leq_1 by (cases fs) auto
            then have fs1: "fs1 = [fv]" using len1_leq_1 fs_fs1 last_fs by (cases fs1) auto
            with aF1 have f12s1: "friends12 s1 = (¬fv)" unfolding vl1 by auto
            have fv: "f ?trn = FrVal fv" and vl': "vl' = OVal True # vlr"
              using c φ unfolding vl fs by (auto simp: consume_def)
            with φ step rs have ?match proof (cases rule: φE)
              case (Friend uid p uid')
                then have IDs1: "IDsOK s1 [UID1, UID2] []"
                  using ss1 unfolding eqButUID_def by auto
                have fv: "fv = True" using fv Friend by auto
                let ?s1' = "createFriend s1 UID1 (pass s1 UID1) UID2"
                have s': "s' = createFriend s UID1 p UID2"
                  using Friend step by (auto simp: createFriend_sym)
                have ss': "eqButUID s s'" using rs step Friend
                  by (auto intro: Cact_cFriend_step_eqButUID)
                moreover then have os': "¬open s'" using os eqButUID_open_eq by auto
                moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al ≠ []"
                                         and tr1: "O (traceOf s1 al) = []"
                                                  "V (traceOf s1 al) = [FrVal True]"
                                         and f12s1': "friends12 ?s1'"
                                         and s1s1': "eqButUID s1 ?s1'"
                  using rs1 IDs1 Friend f12s1 unfolding fv by (auto elim: toggle_friends12_True)
                moreover have "friendIDs s' = friendIDs ?s1'"
                  using Friend(6) f12s1 unfolding s' fv
                  by (intro eqButUID_createFriend12_friendIDs_eq[OF ss1 rs rs1]) auto
                ultimately have "Δ2 s' vl' ?s1' (OVal True # vlr1)"
                  using BO ss1 aF1 unfolding vl' vl1 fs1 f12s1 fv
                  by (intro Δ2_I[of _ _ _ _ _ "[]" "[]"])
                     (auto intro: eqButUID_trans eqButUID_sym)
                moreover have "¬γ ?trn" using Friend UID1_UID2_UIDs by auto
                ultimately show ?match using tr1 vl1 Friend unfolding fs1 fv
                  by (intro matchI_ms[OF al]) (auto simp: consumeList_def)
            next
              case (Unfriend uid p uid')
                then have IDs1: "IDsOK s1 [UID1, UID2] []"
                  using ss1 unfolding eqButUID_def by auto
                have fv: "fv = False" using fv Unfriend by auto
                let ?s1' = "deleteFriend s1 UID1 (pass s1 UID1) UID2"
                have s': "s' = deleteFriend s UID1 p UID2"
                  using Unfriend step by (auto simp: deleteFriend_sym)
                have ss': "eqButUID s s'" using rs step Unfriend
                  by (auto intro: Dact_dFriend_step_eqButUID)
                moreover then have os': "¬open s'" using os eqButUID_open_eq by auto
                moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al ≠ []"
                                         and tr1: "O (traceOf s1 al) = []"
                                                  "V (traceOf s1 al) = [FrVal False]"
                                         and f12s1': "¬friends12 ?s1'"
                                         and s1s1': "eqButUID s1 ?s1'"
                  using rs1 IDs1 Unfriend f12s1 unfolding fv by (auto elim: toggle_friends12_False)
                moreover have "friendIDs s' = friendIDs ?s1'"
                  using Unfriend(6) f12s1 unfolding s' fv
                  by (intro eqButUID_deleteFriend12_friendIDs_eq[OF ss1 rs rs1])
                ultimately have "Δ2 s' vl' ?s1' (OVal True # vlr1)"
                  using BO ss1 aF1 unfolding vl' vl1 fs1 f12s1 fv
                  by (intro Δ2_I[of _ _ _ _ _ "[]" "[]"])
                     (auto intro: eqButUID_trans eqButUID_sym)
                moreover have "¬γ ?trn" using Unfriend UID1_UID2_UIDs by auto
                ultimately show ?match using tr1 vl1 Unfriend unfolding fs1 fv
                  by (intro matchI_ms[OF al]) (auto simp: consumeList_def)
            qed auto
            then show ?thesis ..
          qed
        qed
      next
        assume nφ: "¬φ ?trn"
        then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'"
          using step_open_φ[OF step] step_friends12_φ[OF step] by auto
        have vl': "vl' = vl" using nφ c by (auto simp: consume_def)
        show ?thesis proof (cases "a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧
                                   a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
                                   a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧
                                   a ≠ Dact (dFriend UID2 (pass s UID2) UID1)")
          case True
            obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto
            let ?trn1 = "Trans s1 a ou1 s1'"
            from True nφ have nφ': "¬φ ?trn1" using eqButUID_step_φ[OF ss1 rs rs1 step step1] by auto
            then have f12s1': "friends12 s1 = friends12 s1'"
              using step_friends12_φ[OF step1] by auto
            have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
            moreover have "friendIDs s = friendIDs s1 ⟶ friendIDs s' = friendIDs s1'"
              using eqButUID_step_friendIDs_eq[OF ss1 rs rs1 step step1 True] ..
            ultimately have "Δ2 s' vl' s1' vl1"
              using os' os aF1 BO fs_fs1 last_fs fs_fIDs unfolding f12s1' vl' vl vl1
              by (intro Δ2_I) auto
            then have ?match
              using step1 nφ' os eqButUID_step_γ_out[OF ss1 step step1]
              by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def)
            then show "?match ∨ ?ignore" ..
        next
          case False
            with nφ have "ou ≠ outOK" by auto
            then have "s' = s" using step False by auto
            then have ?ignore using 2 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto
            then show "?match ∨ ?ignore" ..
        qed
      qed
    qed
    then show ?thesis unfolding vl by auto
  qed
qed


definition Gr where
"Gr =
 {
 (Δ0, {Δ0,Δ1,Δ2}),
 (Δ1, {Δ1,Δ0}),
 (Δ2, {Δ2,Δ0})
 }"


theorem secure: secure
apply (rule unwind_decomp_secure_graph[of Gr Δ0])
unfolding Gr_def
apply (simp, smt insert_subset order_refl)
using
istate_Δ0 unwind_cont_Δ0 unwind_cont_Δ1 unwind_cont_Δ2
unfolding Gr_def by (auto intro: unwind_cont_mono)


end
d>

Theory Friend_Request_Intro

theory Friend_Request_Intro
  imports "../Safety_Properties" "../Observation_Setup"
begin

section ‹Friendship request confidentiality›

text ‹We prove the following property:

\ \\
Given a group of users ‹UIDs› and given two users ‹UID1› and ‹UID2› not in that group,

that group cannot learn anything about the friendship requests issued between
‹UID1› and ‹UID2›

beyond what everybody knows, namely that
  ▪ there is no friendship between ‹UID1› and ‹UID2› before those users have been created, and
  ▪ friendship status updates form an alternating sequence of friending and unfriending,
    every successful friend creation is preceded by at least one and at most two requests,

and beyond those requests performed while or last before a user in ‹UIDs› is friends with
‹UID1› or ‹UID2›.›

end

Theory Friend_Request_Value_Setup

(* The value setup for friend confidentiality *)
theory Friend_Request_Value_Setup
imports Friend_Request_Intro
begin

text ‹The confidential information is the friendship requests between two arbitrary but fixed users:›

consts UID1 :: userID
consts UID2 :: userID

axiomatization where
UID1_UID2_UIDs: "{UID1,UID2} ∩ UIDs = {}"
and
UID1_UID2: "UID1 ≠ UID2"

subsection ‹Preliminaries›

(* The notion of two userID lists being equal save for at most one occurrence of uid: *)
fun eqButUIDl :: "userID ⇒ userID list ⇒ userID list ⇒ bool" where
"eqButUIDl uid uidl uidl1 = (remove1 uid uidl = remove1 uid uidl1)"

lemma eqButUIDl_eq[simp,intro!]: "eqButUIDl uid uidl uidl"
by auto

lemma eqButUIDl_sym:
assumes "eqButUIDl uid uidl uidl1"
shows "eqButUIDl uid uidl1 uidl"
using assms by auto

lemma eqButUIDl_trans:
assumes "eqButUIDl uid uidl uidl1" and "eqButUIDl uid uidl1 uidl2"
shows "eqButUIDl uid uidl uidl2"
using assms by auto

lemma eqButUIDl_remove1_cong:
assumes "eqButUIDl uid uidl uidl1"
shows "eqButUIDl uid (remove1 uid' uidl) (remove1 uid' uidl1)"
proof -
  have "remove1 uid (remove1 uid' uidl) = remove1 uid' (remove1 uid uidl)" by (simp add: remove1_commute)
  also have "… = remove1 uid' (remove1 uid uidl1)" using assms by simp
  also have "… = remove1 uid (remove1 uid' uidl1)" by (simp add: remove1_commute)
  finally show ?thesis by simp
qed

lemma eqButUIDl_snoc_cong:
assumes "eqButUIDl uid uidl uidl1"
and "uid' ∈∈ uidl ⟷ uid' ∈∈ uidl1"
shows "eqButUIDl uid (uidl ## uid') (uidl1 ## uid')"
using assms by (auto simp add: remove1_append remove1_idem)

(* The notion of two functions each taking a userID and returning a list of user IDs
  being equal everywhere but on UID1 and UID2, where their return results are allowed
  to be eqButUIDl : *)
definition eqButUIDf where
"eqButUIDf frds frds1 ≡
  eqButUIDl UID2 (frds UID1) (frds1 UID1)
∧ eqButUIDl UID1 (frds UID2) (frds1 UID2)
∧ (∀uid. uid ≠ UID1 ∧ uid ≠ UID2 ⟶ frds uid = frds1 uid)"

lemmas eqButUIDf_intro = eqButUIDf_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUIDf_eeq[simp,intro!]: "eqButUIDf frds frds"
unfolding eqButUIDf_def by auto

lemma eqButUIDf_sym:
assumes "eqButUIDf frds frds1" shows "eqButUIDf frds1 frds"
using assms eqButUIDl_sym unfolding eqButUIDf_def
by presburger

lemma eqButUIDf_trans:
assumes "eqButUIDf frds frds1" and "eqButUIDf frds1 frds2"
shows "eqButUIDf frds frds2"
using assms eqButUIDl_trans unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_cong:
assumes "eqButUIDf frds frds1"
and "uid = UID1 ⟹ eqButUIDl UID2 uu uu1"
and "uid = UID2 ⟹ eqButUIDl UID1 uu uu1"
and "uid ≠ UID1 ⟹ uid ≠ UID2 ⟹ uu = uu1"
shows "eqButUIDf (frds (uid := uu)) (frds1(uid := uu1))"
using assms unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_eqButUIDl:
assumes "eqButUIDf frds frds1"
shows "eqButUIDl UID2 (frds UID1) (frds1 UID1)"
  and "eqButUIDl UID1 (frds UID2) (frds1 UID2)"
using assms unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_not_UID:
"⟦eqButUIDf frds frds1; uid ≠ UID1; uid ≠ UID2⟧ ⟹ frds uid = frds1 uid"
unfolding eqButUIDf_def by (auto split: if_splits)

lemma eqButUIDf_not_UID':
assumes eq1: "eqButUIDf frds frds1"
and uid: "(uid,uid') ∉ {(UID1,UID2), (UID2,UID1)}"
shows "uid ∈∈ frds uid' ⟷ uid ∈∈ frds1 uid'"
proof -
  from uid have "(uid' = UID1 ∧ uid ≠ UID2)
               ∨ (uid' = UID2 ∧ uid ≠ UID1)
               ∨ (uid' ∉ {UID1,UID2})" (is "?u1 ∨ ?u2 ∨ ?n12")
    by auto
  then show ?thesis proof (elim disjE)
    assume "?u1"
    moreover then have "uid ∈∈ remove1 UID2 (frds uid') ⟷ uid ∈∈ remove1 UID2 (frds1 uid')"
      using eq1 unfolding eqButUIDf_def by auto
    ultimately show ?thesis by auto
  next
    assume "?u2"
    moreover then have "uid ∈∈ remove1 UID1 (frds uid') ⟷ uid ∈∈ remove1 UID1 (frds1 uid')"
      using eq1 unfolding eqButUIDf_def by auto
    ultimately show ?thesis by auto
  next
    assume "?n12"
    then show ?thesis using eq1 unfolding eqButUIDf_def by auto
  qed
qed

(* The notion of two functions each taking two userID arguments being
  equal everywhere but on the values (UID1,UID2) and (UID2,UID1): *)
definition eqButUID12 where
"eqButUID12 freq freq1 ≡
 ∀ uid uid'. if (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} then True else freq uid uid' = freq1 uid uid'"

lemmas eqButUID12_intro = eqButUID12_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUID12_eeq[simp,intro!]: "eqButUID12 freq freq"
unfolding eqButUID12_def by auto

lemma eqButUID12_sym:
assumes "eqButUID12 freq freq1" shows "eqButUID12 freq1 freq"
using assms unfolding eqButUID12_def
by presburger

lemma eqButUID12_trans:
assumes "eqButUID12 freq freq1" and "eqButUID12 freq1 freq2"
shows "eqButUID12 freq freq2"
using assms unfolding eqButUID12_def by (auto split: if_splits)

lemma eqButUID12_cong:
assumes "eqButUID12 freq freq1"
and "¬ (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} ⟹ uu = uu1"
shows "eqButUID12 (fun_upd2 freq uid uid' uu) (fun_upd2 freq1 uid uid' uu1)"
using assms unfolding eqButUID12_def fun_upd2_def by (auto split: if_splits)

lemma eqButUID12_not_UID:
"⟦eqButUID12 freq freq1; ¬ (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}⟧ ⟹ freq uid uid' = freq1 uid uid'"
unfolding eqButUID12_def by (auto split: if_splits)


(* The notion of two states being equal everywhere but on the friendship requests or status of users UID1 and UID2: *)
definition eqButUID :: "state ⇒ state ⇒ bool" where
"eqButUID s s1 ≡
 admin s = admin s1 ∧

 pendingUReqs s = pendingUReqs s1 ∧ userReq s = userReq s1 ∧
 userIDs s = userIDs s1 ∧ user s = user s1 ∧ pass s = pass s1 ∧

 eqButUIDf (pendingFReqs s) (pendingFReqs s1) ∧
 eqButUID12 (friendReq s) (friendReq s1) ∧
 eqButUIDf (friendIDs s) (friendIDs s1) ∧

 postIDs s = postIDs s1 ∧ admin s = admin s1 ∧
 post s = post s1 ∧
 owner s = owner s1 ∧
 vis s = vis s1"

lemmas eqButUID_intro = eqButUID_def[THEN meta_eq_to_obj_eq, THEN iffD2]

lemma eqButUID_refl[simp,intro!]: "eqButUID s s"
unfolding eqButUID_def by auto

lemma eqButUID_sym[sym]:
assumes "eqButUID s s1" shows "eqButUID s1 s"
using assms eqButUIDf_sym eqButUID12_sym unfolding eqButUID_def by auto

lemma eqButUID_trans[trans]:
assumes "eqButUID s s1" and "eqButUID s1 s2" shows "eqButUID s s2"
using assms eqButUIDf_trans eqButUID12_trans unfolding eqButUID_def by metis

(* Implications from eqButUID, including w.r.t. auxiliary operations: *)
lemma eqButUID_stateSelectors:
"eqButUID s s1 ⟹
 admin s = admin s1 ∧

 pendingUReqs s = pendingUReqs s1 ∧ userReq s = userReq s1 ∧
 userIDs s = userIDs s1 ∧ user s = user s1 ∧ pass s = pass s1 ∧

 eqButUIDf (pendingFReqs s) (pendingFReqs s1) ∧
 eqButUID12 (friendReq s) (friendReq s1) ∧
 eqButUIDf (friendIDs s) (friendIDs s1) ∧

 postIDs s = postIDs s1 ∧ admin s = admin s1 ∧
 post s = post s1 ∧
 owner s = owner s1 ∧
 vis s = vis s1 ∧

 IDsOK s = IDsOK s1"
unfolding eqButUID_def IDsOK_def[abs_def] by auto

lemma eqButUID_eqButUID2:
"eqButUID s s1 ⟹ eqButUIDl UID2 (friendIDs s UID1) (friendIDs s1 UID1)"
unfolding eqButUID_def using eqButUIDf_eqButUIDl
by (smt eqButUIDf_eqButUIDl eqButUIDl.simps)

lemma eqButUID_not_UID:
"eqButUID s s1 ⟹ uid ≠ UID ⟹ post s uid = post s1 uid"
unfolding eqButUID_def by auto


lemma eqButUID_cong[simp, intro]:
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇admin := uu1⦈) (s1 ⦇admin := uu2⦈)"

"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇pendingUReqs := uu1⦈) (s1 ⦇pendingUReqs := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇userReq := uu1⦈) (s1 ⦇userReq := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇userIDs := uu1⦈) (s1 ⦇userIDs := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇user := uu1⦈) (s1 ⦇user := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇pass := uu1⦈) (s1 ⦇pass := uu2⦈)"

"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇postIDs := uu1⦈) (s1 ⦇postIDs := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇owner := uu1⦈) (s1 ⦇owner := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇post := uu1⦈) (s1 ⦇post := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ uu1 = uu2 ⟹ eqButUID (s ⦇vis := uu1⦈) (s1 ⦇vis := uu2⦈)"

"⋀ uu1 uu2. eqButUID s s1 ⟹ eqButUIDf uu1 uu2 ⟹ eqButUID (s ⦇pendingFReqs := uu1⦈) (s1 ⦇pendingFReqs := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ eqButUID12 uu1 uu2 ⟹ eqButUID (s ⦇friendReq := uu1⦈) (s1 ⦇friendReq := uu2⦈)"
"⋀ uu1 uu2. eqButUID s s1 ⟹ eqButUIDf uu1 uu2 ⟹ eqButUID (s ⦇friendIDs := uu1⦈) (s1 ⦇friendIDs := uu2⦈)"

unfolding eqButUID_def by auto

subsection‹Value Setup›

datatype "fUser" = U1 | U2
datatype "value" =
  isFRVal: FRVal fUser req ― ‹friendship requests from ‹UID1› to ‹UID2› (or vice versa)›
| isFVal: FVal bool ― ‹updates to the status of friendship between them›
| isOVal: OVal bool ― ‹updated dynamic declassification trigger condition›

text ‹The dynamic declassification trigger condition holds, i.e.~the access window to the
confidential information is open, as long as the two users have not been created yet (so there
cannot be friendship between them) or one of them is friends with an observer.›

definition openByA :: "state ⇒ bool" ― ‹Openness by absence›
where "openByA s ≡ ¬ UID1 ∈∈ userIDs s ∨ ¬ UID2 ∈∈ userIDs s"

definition openByF :: "state ⇒ bool" ― ‹Openness by friendship›
where "openByF s ≡ ∃uid ∈ UIDs. uid ∈∈ friendIDs s UID1 ∨ uid ∈∈ friendIDs s UID2"

definition "open" :: "state ⇒ bool"
where "open s ≡ openByA s ∨ openByF s"

lemmas open_defs = open_def openByA_def openByF_def

definition "friends12" :: "state ⇒ bool"
where "friends12 s ≡ UID1 ∈∈ friendIDs s UID2 ∧ UID2 ∈∈ friendIDs s UID1"

fun φ :: "(state,act,out) trans ⇒ bool" where
"φ (Trans s (Cact (cFriendReq uid p uid' req)) ou s') =
  ((uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} ∧ ou = outOK)"
|
"φ (Trans s (Cact (cFriend uid p uid')) ou s') =
  ((uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} ∧ ou = outOK ∨
   open s ≠ open s')"
|
"φ (Trans s (Dact (dFriend uid p uid')) ou s') =
  ((uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} ∧ ou = outOK ∨
   open s ≠ open s')"
|
"φ (Trans s (Cact (cUser uid p uid' p')) ou s') =
  (open s ≠ open s')"
|
"φ _ = False"

fun f :: "(state,act,out) trans ⇒ value" where
"f (Trans s (Cact (cFriendReq uid p uid' req)) ou s') =
    (if uid = UID1 ∧ uid' = UID2 then FRVal U1 req
else if uid = UID2 ∧ uid' = UID1 then FRVal U2 req
                                 else OVal True)"
|
"f (Trans s (Cact (cFriend uid p uid')) ou s') =
  (if (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} then FVal True
                                              else OVal True)"
|
"f (Trans s (Dact (dFriend uid p uid')) ou s') =
  (if (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)} then FVal False
                                              else OVal False)"
|
"f (Trans s (Cact (cUser uid p uid' p')) ou s') = OVal False"
|
"f _ = undefined"


lemma φE:
assumes φ: "φ (Trans s a ou s')" (is "φ ?trn")
and step: "step s a = (ou, s')"
and rs: "reach s"
obtains (FReq1) u p req where "a = Cact (cFriendReq UID1 p UID2 req)" "ou = outOK"
                              "f ?trn = FRVal u req" "u = U1" "IDsOK s [UID1, UID2] []"
                              "¬friends12 s" "¬friends12 s'" "open s' = open s"
                              "UID1 ∈∈ pendingFReqs s' UID2" "UID1 ∉ set (pendingFReqs s UID2)"
                              "UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1"
      | (FReq2) u p req where "a = Cact (cFriendReq UID2 p UID1 req)" "ou = outOK"
                              "f ?trn = FRVal u req" "u = U2" "IDsOK s [UID1, UID2] []"
                              "¬friends12 s" "¬friends12 s'" "open s' = open s"
                              "UID2 ∈∈ pendingFReqs s' UID1" "UID2 ∉ set (pendingFReqs s UID1)"
                              "UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2"
      | (Friend) uid p uid' where "a = Cact (cFriend uid p uid')" "ou = outOK" "f ?trn = FVal True"
                                  "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1"
                                  "IDsOK s [UID1, UID2] []"
                                  "¬friends12 s" "friends12 s'" "uid' ∈∈ pendingFReqs s uid"
                                  "UID1 ∉ set (pendingFReqs s' UID2)"
                                  "UID2 ∉ set (pendingFReqs s' UID1)"
      | (Unfriend) uid p uid' where "a = Dact (dFriend uid p uid')" "ou = outOK" "f ?trn = FVal False"
                                    "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1"
                                    "IDsOK s [UID1, UID2] []"
                                    "friends12 s" "¬friends12 s'"
                                    "UID1 ∉ set (pendingFReqs s' UID2)"
                                    "UID1 ∉ set (pendingFReqs s UID2)"
                                    "UID2 ∉ set (pendingFReqs s' UID1)"
                                    "UID2 ∉ set (pendingFReqs s UID1)"
      | (OpenF) uid p uid' where "a = Cact (cFriend uid p uid')"
                                 "(uid ∈ UIDs ∧ uid' ∈ {UID1,UID2}) ∨ (uid' ∈ UIDs ∧ uid ∈ {UID1,UID2})"
                                 "ou = outOK" "f ?trn = OVal True" "¬openByF s" "openByF s'"
                                 "¬openByA s" "¬openByA s'"
                                 "friends12 s' = friends12 s"
                                 "UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2"
                                 "UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1"
      | (CloseF) uid p uid' where "a = Dact (dFriend uid p uid')"
                                  "(uid ∈ UIDs ∧ uid' ∈ {UID1,UID2}) ∨ (uid' ∈ UIDs ∧ uid ∈ {UID1,UID2})"
                                  "ou = outOK" "f ?trn = OVal False" "openByF s" "¬openByF s'"
                                  "¬openByA s" "¬openByA s'"
                                  "friends12 s' = friends12 s"
                                  "UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2"
                                  "UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1"
      | (CloseA) uid p uid' p' where "a = Cact (cUser uid p uid' p')"
                                     "uid' ∈ {UID1,UID2}" "openByA s" "¬openByA s'"
                                     "¬openByF s" "¬openByF s'"
                                     "ou = outOK" "f ?trn = OVal False"
                                     "friends12 s' = friends12 s"
                                     "UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2"
                                     "UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1"
using φ proof (elim φ.elims disjE conjE)
  fix s1 uid p uid' req ou1 s1'
  assume "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK"
     and "?trn = Trans s1 (Cact (cFriendReq uid p uid' req)) ou1 s1'"
  then have trn: "a = Cact (cFriendReq uid p uid' req)" "s = s1" "s' = s1'" "ou = ou1"
        and uids: "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1" using UID1_UID2 by auto
  from uids show thesis proof
    assume "uid = UID1 ∧ uid' = UID2"
    then show thesis using ou uids trn step UID1_UID2_UIDs UID1_UID2 reach_distinct_friends_reqs[OF rs]
      by (intro FReq1[of p req]) (auto simp add: c_defs friends12_def open_defs)
  next
    assume "uid = UID2 ∧ uid' = UID1"
    then show thesis using ou uids trn step UID1_UID2_UIDs UID1_UID2 reach_distinct_friends_reqs[OF rs]
      by (intro FReq2[of p req]) (auto simp add: c_defs friends12_def open_defs)
  qed
next
  fix s1 uid p uid' ou1 s1'
  assume "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK"
     and "?trn = Trans s1 (Cact (cFriend uid p uid')) ou1 s1'"
  then have trn: "a = Cact (cFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1"
        and uids: "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1" using UID1_UID2 by auto
  then show thesis using ou uids trn step UID1_UID2_UIDs UID1_UID2 reach_distinct_friends_reqs[OF rs]
    by (intro Friend[of uid p uid']) (auto simp add: c_defs friends12_def)
next
  fix s1 uid p uid' ou1 s1'
  assume op: "open s1 ≠ open s1'"
     and "?trn = Trans s1 (Cact (cFriend uid p uid')) ou1 s1'"
  then have trn: "a = Cact (cFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" by auto
  then have uids: "uid ∈ UIDs ∧ uid' ∈ {UID1, UID2} ∨ uid ∈ {UID1, UID2} ∧ uid' ∈ UIDs" "ou = outOK"
                  "¬openByF s1" "openByF s1'" "¬openByA s1" "¬openByA s1'"
    using op step by (auto simp add: c_defs open_def openByA_def openByF_def)
  moreover have "friends12 s1' ⟷ friends12 s1"
    using step trn uids UID1_UID2 UID1_UID2_UIDs
    by (cases "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}") (auto simp add: c_defs friends12_def)
  moreover have "UID1 ∈∈ pendingFReqs s1' UID2 ⟷ UID1 ∈∈ pendingFReqs s1 UID2"
    using step trn uids UID1_UID2 UID1_UID2_UIDs
    by (cases "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}") (auto simp add: c_defs)
  moreover have "UID2 ∈∈ pendingFReqs s1' UID1 ⟷ UID2 ∈∈ pendingFReqs s1 UID1"
    using step trn uids UID1_UID2 UID1_UID2_UIDs
    by (cases "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}") (auto simp add: c_defs)
  ultimately show thesis using op trn step UID1_UID2_UIDs UID1_UID2 by (intro OpenF) auto
next
  fix s1 uid p uid' ou1 s1'
  assume "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}" and ou: "ou1 = outOK"
     and "?trn = Trans s1 (Dact (dFriend uid p uid')) ou1 s1'"
  then have trn: "a = Dact (dFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1"
        and uids: "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1" using UID1_UID2 by auto
  then show thesis using step ou reach_friendIDs_symmetric[OF rs] reach_distinct_friends_reqs[OF rs]
    by (intro Unfriend; auto simp: d_defs friends12_def) blast+
next
  fix s1 uid p uid' ou1 s1'
  assume op: "open s1 ≠ open s1'"
     and "?trn = Trans s1 (Dact (dFriend uid p uid')) ou1 s1'"
  then have trn: "a = Dact (dFriend uid p uid')" "s = s1" "s' = s1'" "ou = ou1" by auto
  then have uids: "uid ∈ UIDs ∧ uid' ∈ {UID1, UID2} ∨ uid ∈ {UID1, UID2} ∧ uid' ∈ UIDs" "ou = outOK"
                  "openByF s1" "¬openByF s1'" "¬openByA s1" "¬openByA s1'"
    using op step by (auto simp add: d_defs open_def openByA_def openByF_def)
  moreover have "friends12 s1' ⟷ friends12 s1"
    using step trn uids UID1_UID2 UID1_UID2_UIDs
    by (cases "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}") (auto simp add: d_defs friends12_def)
  ultimately show thesis using op trn step UID1_UID2_UIDs UID1_UID2 by (intro CloseF; auto simp: d_defs)
next
  fix s1 uid p uid' p' ou1 s1'
  assume op: "open s1 ≠ open s1'"
     and "?trn = Trans s1 (Cact (cUser uid p uid' p')) ou1 s1'"
  then have trn: "a = Cact (cUser uid p uid' p')" "s = s1" "s' = s1'" "ou = ou1" by auto
  then have uids: "uid' = UID2 ∨ uid' = UID1" "ou = outOK"
                  "¬openByF s1" "¬openByF s1'" "openByA s1" "¬openByA s1'"
    using op step by (auto simp add: c_defs open_def openByF_def openByA_def)
  moreover have "friends12 s1' ⟷ friends12 s1"
    using step trn uids UID1_UID2 UID1_UID2_UIDs
    by (cases "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}") (auto simp add: c_defs friends12_def)
  ultimately show thesis using trn step UID1_UID2_UIDs UID1_UID2 by (intro CloseA) (auto simp: c_defs)
qed

lemma step_open_φ:
assumes "step s a = (ou, s')"
and "open s ≠ open s'"
shows "φ (Trans s a ou s')"
using assms proof (cases a)
  case (Sact sa) then show ?thesis using assms UID1_UID2 by (cases sa) (auto simp: s_defs open_defs) next
  case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs open_defs) next
  case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs open_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs open_defs)
qed auto

lemma step_friends12_φ:
assumes "step s a = (ou, s')"
and "friends12 s ≠ friends12 s'"
shows "φ (Trans s a ou s')"
using assms proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs friends12_def) next
  case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs friends12_def) next
  case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs friends12_def) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs friends12_def)
qed auto

lemma step_pendingFReqs_φ:
assumes "step s a = (ou, s')"
and "(UID1 ∈∈ pendingFReqs s UID2) ≠ (UID1 ∈∈ pendingFReqs s' UID2)
   ∨ (UID2 ∈∈ pendingFReqs s UID1) ≠ (UID2 ∈∈ pendingFReqs s' UID1)"
shows "φ (Trans s a ou s')"
using assms proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs) next
  case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: c_defs) next
  case (Dact da) then show ?thesis using assms by (cases da) (auto simp: d_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs)
qed auto

lemma eqButUID_friends12_set_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and f12: "friends12 s = friends12 s1"
and rs: "reach s" and rs1: "reach s1"
shows "set (friendIDs s uid) = set (friendIDs s1 uid)"
proof -
  have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s1 uid)"
    using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto
  from f12 have uid12: "UID1 ∈∈ friendIDs s UID2 ⟷ UID1 ∈∈ friendIDs s1 UID2"
                       "UID2 ∈∈ friendIDs s UID1 ⟷ UID2 ∈∈ friendIDs s1 UID1"
    using reach_friendIDs_symmetric[OF rs] reach_friendIDs_symmetric[OF rs1]
    unfolding friends12_def by auto
  from ss1 have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" unfolding eqButUID_def by simp
  show "set (friendIDs s uid) = set (friendIDs s1 uid)"
  proof (intro equalityI subsetI)
    fix uid'
    assume "uid' ∈∈ friendIDs s uid"
    then show "uid' ∈∈ friendIDs s1 uid"
      using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def
      by (metis (no_types, lifting) insert_iff prod.inject singletonD)
  next
    fix uid'
    assume "uid' ∈∈ friendIDs s1 uid"
    then show "uid' ∈∈ friendIDs s uid"
      using fIDs dfIDs uid12 eqButUIDf_not_UID' unfolding eqButUIDf_def
      by (metis (no_types, lifting) insert_iff prod.inject singletonD)
  qed
qed


lemma distinct_remove1_idem: "distinct xs ⟹ remove1 y (remove1 y xs) = remove1 y xs"
by (induction xs) (auto simp add: remove1_idem)

lemma Cact_cFriend_step_eqButUID:
assumes step: "step s (Cact (cFriend uid p uid')) = (ou,s')"
and s: "reach s"
and uids: "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)" (is "?u12 ∨ ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid' ∈∈ pendingFReqs s uid" using step by (auto simp add: c_defs)
  then have fIDs: "uid' ∉ set (friendIDs s uid)" "uid ∉ set (friendIDs s uid')"
        and fRs: "distinct (pendingFReqs s uid)" "distinct (pendingFReqs s uid')"
    using reach_distinct_friends_reqs[OF s] by auto
  have "eqButUIDf (friendIDs s) (friendIDs (createFriend s uid p uid'))"
    using fIDs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append)
  moreover have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriend s uid p uid'))"
    using fRs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs distinct_remove1_idem)
  moreover have "eqButUID12 (friendReq s) (friendReq (createFriend s uid p uid'))"
    using uids unfolding eqButUID12_def
    by (auto simp add: c_defs fun_upd2_eq_but_a_b)
  ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs)
qed (auto)

lemma Cact_cFriendReq_step_eqButUID:
assumes step: "step s (Cact (cFriendReq uid p uid' req)) = (ou,s')"
and uids: "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)" (is "?u12 ∨ ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid ∉ set (pendingFReqs s uid')" "uid ∉ set (friendIDs s uid')"
    using step by (auto simp add: c_defs)
  then have "eqButUIDf (pendingFReqs s) (pendingFReqs (createFriendReq s uid p uid' req))"
    using uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: c_defs remove1_idem remove1_append)
  moreover have "eqButUID12 (friendReq s) (friendReq (createFriendReq s uid p uid' req))"
    using uids unfolding eqButUID12_def
    by (auto simp add: c_defs fun_upd2_eq_but_a_b)
  ultimately show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: c_defs)
qed (auto)


lemma Dact_dFriend_step_eqButUID:
assumes step: "step s (Dact (dFriend uid p uid')) = (ou,s')"
and s: "reach s"
and uids: "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)" (is "?u12 ∨ ?u21")
shows "eqButUID s s'"
using assms proof (cases)
  assume ou: "ou = outOK"
  then have "uid' ∈∈ friendIDs s uid" using step by (auto simp add: d_defs)
  then have fRs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')"
    using reach_distinct_friends_reqs[OF s] by auto
  have "eqButUIDf (friendIDs s) (friendIDs (deleteFriend s uid p uid'))"
    using fRs uids UID1_UID2 unfolding eqButUIDf_def
    by (cases "?u12") (auto simp add: d_defs remove1_idem distinct_remove1_removeAll)
  then show "eqButUID s s'" using step ou unfolding eqButUID_def by (auto simp add: d_defs)
qed (auto)


(*  Key lemma:  *)
lemma eqButUID_step:
assumes ss1: "eqButUID s s1"
and step: "step s a = (ou,s')"
and step1: "step s1 a = (ou1,s1')"
and rs: "reach s"
and rs1: "reach s1"
shows "eqButUID s' s1'"
proof -
  note simps = eqButUID_def s_defs c_defs u_defs r_defs l_defs
  from assms show ?thesis proof (cases a)
    case (Sact sa) with assms show ?thesis by (cases sa) (auto simp add: simps)
  next
    case (Cact ca) note a = this
      with assms show ?thesis proof (cases ca)
        case (cFriendReq uid p uid' req) note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 unfolding a ca
                by (auto intro: Cact_cFriendReq_step_eqButUID)
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
               and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid ∈∈ pendingFReqs s uid' ⟷ uid ∈∈ pendingFReqs s1 uid'"
                                  "uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'"
                using False by (auto intro!: eqButUIDf_not_UID')
              have "eqButUIDf ((pendingFReqs s)(uid' := pendingFReqs s uid' ## uid))
                              ((pendingFReqs s1)(uid' := pendingFReqs s1 uid' ## uid))"
                using fRs False
                by (intro eqButUIDf_cong) (auto simp add: remove1_append remove1_idem eqButUIDf_def)
              moreover have "eqButUID12 (fun_upd2 (friendReq s) uid uid' req)
                                        (fun_upd2 (friendReq s1) uid uid' req)"
                using ss1 by (intro eqButUID12_cong) (auto simp: simps)
              moreover have "e_createFriendReq s uid p uid' req
                         ⟷ e_createFriendReq s1 uid p uid' req"
                using uid_uid' ss1 by (auto simp: simps)
              ultimately show ?thesis using assms unfolding a ca by (auto simp: simps)
          qed
      next
        case (cFriend uid p uid') note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 rs rs1 unfolding a ca
                by (auto intro!: Cact_cFriend_step_eqButUID)+
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fRs: "eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
                    (is "eqButUIDf (?pfr s) (?pfr s1)")
               and fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid ∈∈ pendingFReqs s uid' ⟷ uid ∈∈ pendingFReqs s1 uid'"
                                  "uid' ∈∈ pendingFReqs s uid ⟷ uid' ∈∈ pendingFReqs s1 uid"
                                  "uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'"
                                  "uid' ∈∈ friendIDs s uid ⟷ uid' ∈∈ friendIDs s1 uid"
                using False by (auto intro!: eqButUIDf_not_UID')
              have "eqButUIDl UID1 (remove1 uid' (?pfr s UID2)) (remove1 uid' (?pfr s1 UID2))"
               and "eqButUIDl UID2 (remove1 uid' (?pfr s UID1)) (remove1 uid' (?pfr s1 UID1))"
               and "eqButUIDl UID1 (remove1 uid (?pfr s UID2)) (remove1 uid (?pfr s1 UID2))"
               and "eqButUIDl UID2 (remove1 uid (?pfr s UID1)) (remove1 uid (?pfr s1 UID1))"
               using fRs unfolding eqButUIDf_def
               by (auto intro!: eqButUIDl_remove1_cong simp del: eqButUIDl.simps)
              then have 1: "eqButUIDf ((?pfr s)(uid := remove1 uid' (?pfr s uid),
                                                uid' := remove1 uid (?pfr s uid')))
                                     ((?pfr s1)(uid := remove1 uid' (?pfr s1 uid),
                                                uid' := remove1 uid (?pfr s1 uid')))"
                using fRs False
                by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have "uid = UID1 ⟹ eqButUIDl UID2 (friendIDs s UID1 ## uid') (friendIDs s1 UID1 ## uid')"
               and "uid = UID2 ⟹ eqButUIDl UID1 (friendIDs s UID2 ## uid') (friendIDs s1 UID2 ## uid')"
               and "uid' = UID1 ⟹ eqButUIDl UID2 (friendIDs s UID1 ## uid) (friendIDs s1 UID1 ## uid)"
               and "uid' = UID2 ⟹ eqButUIDl UID1 (friendIDs s UID2 ## uid) (friendIDs s1 UID2 ## uid)"
                using fIDs uid_uid' by - (intro eqButUIDl_snoc_cong; simp add: eqButUIDf_def)+
              then have 2: "eqButUIDf ((friendIDs s)(uid := friendIDs s uid ## uid',
                                                      uid' := friendIDs s uid' ## uid))
                                       ((friendIDs s1)(uid := friendIDs s1 uid ## uid',
                                                       uid' := friendIDs s1 uid' ## uid))"
                using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have 3: "eqButUID12 (fun_upd2 (fun_upd2 (friendReq s) uid' uid emptyReq)
                                                                    uid uid' emptyReq)
                                  (fun_upd2 (fun_upd2 (friendReq s1) uid' uid emptyReq)
                                                                     uid uid' emptyReq)"
                using ss1 by (intro eqButUID12_cong) (auto simp: simps)
              have "e_createFriend s uid p uid'
                ⟷ e_createFriend s1 uid p uid'"
                using uid_uid' ss1 by (auto simp: simps)
              with 1 2 3 show ?thesis using assms unfolding a ca by (auto simp: simps)
          qed
      qed (auto simp: simps)
  next
    case (Uact ua) with assms show ?thesis by (cases ua) (auto simp add: simps)
  next
    case (Ract ra) with assms show ?thesis by (cases ra) (auto simp add: simps)
  next
    case (Lact la) with assms show ?thesis by (cases la) (auto simp add: simps)
  next
    case (Dact da) note a = this
      with assms show ?thesis proof (cases da)
        case (dFriend uid p uid') note ca = this
          then show ?thesis
          proof (cases "(uid = UID1 ∧ uid' = UID2) ∨ (uid = UID2 ∧ uid' = UID1)")
            case True
              then have "eqButUID s s'" and "eqButUID s1 s1'"
                using step step1 rs rs1 unfolding a ca
                by (auto intro!: Dact_dFriend_step_eqButUID)+
              with ss1 show "eqButUID s' s1'" by (auto intro: eqButUID_sym eqButUID_trans)
          next
            case False
              have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" using ss1 by (auto simp: simps)
              then have uid_uid': "uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'"
                                  "uid' ∈∈ friendIDs s uid ⟷ uid' ∈∈ friendIDs s1 uid"
                using False by (auto intro!: eqButUIDf_not_UID')
              have dfIDs: "distinct (friendIDs s uid)" "distinct (friendIDs s uid')"
                          "distinct (friendIDs s1 uid)" "distinct (friendIDs s1 uid')"
                using reach_distinct_friends_reqs[OF rs] reach_distinct_friends_reqs[OF rs1] by auto
              have "uid = UID1 ⟹ eqButUIDl UID2 (remove1 uid' (friendIDs s UID1)) (remove1 uid' (friendIDs s1 UID1))"
               and "uid = UID2 ⟹ eqButUIDl UID1 (remove1 uid' (friendIDs s UID2)) (remove1 uid' (friendIDs s1 UID2))"
               and "uid' = UID1 ⟹ eqButUIDl UID2 (remove1 uid (friendIDs s UID1)) (remove1 uid (friendIDs s1 UID1))"
               and "uid' = UID2 ⟹ eqButUIDl UID1 (remove1 uid (friendIDs s UID2)) (remove1 uid (friendIDs s1 UID2))"
                using fIDs uid_uid' by - (intro eqButUIDl_remove1_cong; simp add: eqButUIDf_def)+
              then have 1: "eqButUIDf ((friendIDs s)(uid := remove1 uid' (friendIDs s uid),
                                                      uid' := remove1 uid (friendIDs s uid')))
                                       ((friendIDs s1)(uid := remove1 uid' (friendIDs s1 uid),
                                                       uid' := remove1 uid (friendIDs s1 uid')))"
                using fIDs by (intro eqButUIDf_cong) (auto simp add: eqButUIDf_def)
              have "e_deleteFriend s uid p uid'
                ⟷ e_deleteFriend s1 uid p uid'"
                using uid_uid' ss1 by (auto simp: simps d_defs)
              with 1 show ?thesis using assms dfIDs unfolding a ca
                by (auto simp: simps d_defs distinct_remove1_removeAll)
          qed
      qed
  qed
qed

lemma eqButUID_openByA_eq:
assumes "eqButUID s s1"
shows "openByA s = openByA s1"
using assms unfolding openByA_def eqButUID_def by auto

lemma eqButUID_openByF_eq:
assumes ss1: "eqButUID s s1"
shows "openByF s = openByF s1"
proof -
  from ss1 have fIDs: "eqButUIDf (friendIDs s) (friendIDs s1)" unfolding eqButUID_def by auto
  have "∀uid ∈ UIDs. uid ∈∈ friendIDs s UID1 ⟷ uid ∈∈ friendIDs s1 UID1"
    using UID1_UID2_UIDs UID1_UID2 by (intro ballI eqButUIDf_not_UID'[OF fIDs]; auto)
  moreover have "∀uid ∈ UIDs. uid ∈∈ friendIDs s UID2 ⟷ uid ∈∈ friendIDs s1 UID2"
    using UID1_UID2_UIDs UID1_UID2 by (intro ballI eqButUIDf_not_UID'[OF fIDs]; auto)
  ultimately show "openByF s = openByF s1" unfolding openByF_def by auto
qed

lemma eqButUID_open_eq: "eqButUID s s1 ⟹ open s = open s1"
using eqButUID_openByA_eq eqButUID_openByF_eq unfolding open_def by blast

lemma eqButUID_step_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and a: "a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧ a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
        a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧ a ≠ Dact (dFriend UID2 (pass s UID2) UID1)"
and "friendIDs s = friendIDs s1"
shows "friendIDs s' = friendIDs s1'"
using assms proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: s_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: u_defs) next
  case (Dact da) then show ?thesis using assms proof (cases da)
    case (dFriend uid p uid')
      with Dact assms show ?thesis
        by (cases "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}")
           (auto simp: d_defs eqButUID_def eqButUIDf_not_UID')
    qed
next
  case (Cact ca) then show ?thesis using assms proof (cases ca)
    case (cFriend uid p uid')
      with Cact assms show ?thesis
        by (cases "(uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}")
           (auto simp: c_defs eqButUID_def eqButUIDf_not_UID')
    qed (auto simp: c_defs)
qed auto

lemma eqButUID_step_φ_imp:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and a: "∀req. a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧
              a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
              a ≠ Cact (cFriendReq UID1 (pass s UID1) UID2 req) ∧
              a ≠ Cact (cFriendReq UID2 (pass s UID2) UID1 req) ∧
              a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧
              a ≠ Dact (dFriend UID2 (pass s UID2) UID1)"
and φ: "φ (Trans s a ou s')"
shows "φ (Trans s1 a ou1 s1')"
proof -
  have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
  then have "open s = open s1" and "open s' = open s1'"
        and "openByA s = openByA s1" and "openByA s' = openByA s1'"
        and "openByF s = openByF s1" and "openByF s' = openByF s1'"
    using ss1 by (auto simp: eqButUID_open_eq eqButUID_openByA_eq eqButUID_openByF_eq)
  with φ a step step1 show "φ (Trans s1 a ou1 s1')" using UID1_UID2_UIDs
    by (elim φ.elims) (auto simp: c_defs d_defs)
qed

(* Key lemma: *)
lemma eqButUID_step_φ:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and a: "∀req. a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧
              a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
              a ≠ Cact (cFriendReq UID1 (pass s UID1) UID2 req) ∧
              a ≠ Cact (cFriendReq UID2 (pass s UID2) UID1 req) ∧
              a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧
              a ≠ Dact (dFriend UID2 (pass s UID2) UID1)"
shows "φ (Trans s a ou s') = φ (Trans s1 a ou1 s1')"
proof
  assume "φ (Trans s a ou s')"
  with assms show "φ (Trans s1 a ou1 s1')" by (rule eqButUID_step_φ_imp)
next
  assume "φ (Trans s1 a ou1 s1')"
  moreover have "eqButUID s1 s" using ss1 by (rule eqButUID_sym)
  moreover have "∀req. a ≠ Cact (cFriend UID1 (pass s1 UID1) UID2) ∧
                       a ≠ Cact (cFriend UID2 (pass s1 UID2) UID1) ∧
                       a ≠ Cact (cFriendReq UID1 (pass s1 UID1) UID2 req) ∧
                       a ≠ Cact (cFriendReq UID2 (pass s1 UID2) UID1 req) ∧
                       a ≠ Dact (dFriend UID1 (pass s1 UID1) UID2) ∧
                       a ≠ Dact (dFriend UID2 (pass s1 UID2) UID1)"
    using a ss1 unfolding eqButUID_def by auto
  ultimately show "φ (Trans s a ou s')" using rs rs1 step step1
    by (intro eqButUID_step_φ_imp[of s1 s])
qed

lemma createFriend_sym: "createFriend s uid p uid' = createFriend s uid' p' uid"
unfolding c_defs by (cases "uid = uid'") (auto simp: fun_upd2_comm fun_upd_twist)

lemma deleteFriend_sym: "deleteFriend s uid p uid' = deleteFriend s uid' p' uid"
unfolding d_defs by (cases "uid = uid'") (auto simp: fun_upd_twist)

lemma createFriendReq_createFriend_absorb:
assumes "e_createFriendReq s uid' p uid req"
shows "createFriend (createFriendReq s uid' p1 uid req) uid p2 uid' = createFriend s uid p3 uid'"
using assms unfolding c_defs by (auto simp: remove1_idem remove1_append fun_upd2_absorb)

lemma eqButUID_deleteFriend12_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
shows "friendIDs (deleteFriend s UID1 p UID2) = friendIDs (deleteFriend s1 UID1 p' UID2)"
proof -
  have "distinct (friendIDs s UID1)" "distinct (friendIDs s UID2)"
       "distinct (friendIDs s1 UID1)" "distinct (friendIDs s1 UID2)"
    using rs rs1 by (auto intro: reach_distinct_friends_reqs)
  then show ?thesis
    using ss1 unfolding eqButUID_def eqButUIDf_def unfolding d_defs
    by (auto simp: distinct_remove1_removeAll)
qed

lemma eqButUID_createFriend12_friendIDs_eq:
assumes ss1: "eqButUID s s1"
and rs: "reach s" and rs1: "reach s1"
and f12: "¬friends12 s" "¬friends12 s1"
shows "friendIDs (createFriend s UID1 p UID2) = friendIDs (createFriend s1 UID1 p' UID2)"
proof -
  have f12': "UID1 ∉ set (friendIDs s UID2)" "UID2 ∉ set (friendIDs s UID1)"
             "UID1 ∉ set (friendIDs s1 UID2)" "UID2 ∉ set (friendIDs s1 UID1)"
    using f12 rs rs1 reach_friendIDs_symmetric unfolding friends12_def by auto
  have "friendIDs s = friendIDs s1"
  proof (intro ext)
    fix uid
    show "friendIDs s uid = friendIDs s1 uid"
      using ss1 f12' unfolding eqButUID_def eqButUIDf_def
      by (cases "uid = UID1 ∨ uid = UID2") (auto simp: remove1_idem)
  qed
  then show ?thesis by (auto simp: c_defs)
qed

end
body>

Theory Friend_Request

theory Friend_Request
imports "../Observation_Setup" Friend_Request_Value_Setup
begin

subsection ‹Declassification bound›


fun T :: "(state,act,out) trans ⇒ bool"
where "T (Trans _ _ _ _) = False"

text ‹Friendship updates form an alternating sequence of friending and unfriending,
and every successful friend creation is preceded by one or two friendship requests.›

fun validValSeq :: "value list ⇒ bool ⇒ bool ⇒ bool ⇒ bool" where
  "validValSeq [] _ _ _ = True"
| "validValSeq (FRVal U1 req # vl) st r1 r2 ⟷ (¬st) ∧ (¬r1) ∧ validValSeq vl st True r2"
| "validValSeq (FRVal U2 req # vl) st r1 r2 ⟷ (¬st) ∧ (¬r2) ∧ validValSeq vl st r1 True"
| "validValSeq (FVal True # vl) st r1 r2 ⟷ (¬st) ∧ (r1 ∨ r2) ∧ validValSeq vl True False False"
| "validValSeq (FVal False # vl) st r1 r2 ⟷ st ∧ (¬r1) ∧ (¬r2) ∧ validValSeq vl False False False"
| "validValSeq (OVal True # vl) st r1 r2 ⟷ validValSeq vl st r1 r2"
| "validValSeq (OVal False # vl) st r1 r2 ⟷ validValSeq vl st r1 r2"

abbreviation validValSeqFrom :: "value list ⇒ state ⇒ bool"
where "validValSeqFrom vl s
 ≡ validValSeq vl (friends12 s) (UID1 ∈∈ pendingFReqs s UID2) (UID2 ∈∈ pendingFReqs s UID1)"

text ‹With respect to the friendship status updates, we use the same
``while-or-last-before'' bound as for friendship status confidentiality.›

inductive BO :: "value list ⇒ value list ⇒ bool"
and BC :: "value list ⇒ value list ⇒ bool"
where
 BO_FVal[simp,intro!]:
  "BO (map FVal fs) (map FVal fs)"
|BO_BC[intro]:
  "BC vl vl1 ⟹
   BO (map FVal fs @ OVal False # vl) (map FVal fs @ OVal False # vl1)"
(*  *)
|BC_FVal[simp,intro!]:
  "BC (map FVal fs) (map FVal fs1)"
|BC_BO[intro]:
  "BO vl vl1 ⟹ (fs = [] ⟷ fs1 = []) ⟹ (fs ≠ [] ⟹ last fs = last fs1) ⟹
   BC (map FVal fs  @ OVal True # vl)
      (map FVal fs1 @ OVal True # vl1)"

text ‹Taking into account friendship requests, two value sequences ‹vl› and ‹vl1› are in the bound if
  ▪ ‹vl1› (with friendship requests) forms a valid value sequence,
  ▪ ‹vl› and ‹vl1› are in ‹BO› (without friendship requests),
  ▪ ‹vl1› is empty if ‹vl› is empty, and
  ▪ ‹vl1› begins with term‹OVal False› if ‹vl› begins with term‹OVal False›.

The last two points are due to the fact that term‹UID1› and term‹UID1› might not exist yet
if ‹vl› is empty (or before term‹OVal False›), in which case the observer can deduce that no
friendship request has happened yet.›

definition "B vl vl1 ≡ BO (filter (Not o isFRVal) vl) (filter (Not o isFRVal) vl1) ∧
                       validValSeqFrom vl1 istate ∧
                       (vl = [] ⟶ vl1 = []) ∧
                       (vl ≠ [] ∧ hd vl = OVal False ⟶ vl1 ≠ [] ∧ hd vl1 = OVal False)"


lemma BO_Nil_iff: "BO vl vl1 ⟹ vl = [] ⟷ vl1 = []"
by (cases rule: BO.cases) auto

no_notation relcomp (infixr "O" 75)

interpretation BD_Security_IO where
istate = istate and step = step and
φ = φ and f = f and γ = γ and g = g and T = T and B = B
done

(* sanity check *) lemma validFrom_validValSeq:
assumes "validFrom s tr"
and "reach s"
shows "validValSeqFrom (V tr) s"
using assms proof (induction tr arbitrary: s)
  case (Cons trn tr s)
    then obtain a ou s' where trn: "trn = Trans s a ou s'"
                          and step: "step s a = (ou, s')"
                          and tr: "validFrom s' tr"
                          and s': "reach s'"
      by (cases trn) (auto iff: validFrom_Cons intro: reach_PairI)
    then have vVS_tr: "validValSeqFrom (V tr) s'" by (intro Cons.IH)
    show ?case proof cases
      assume φ: "φ (Trans s a ou s')"
      then have V: "V (Trans s a ou s' # tr) = f (Trans s a ou s') # V tr" by auto
      from φ vVS_tr Cons.prems step show ?thesis unfolding trn V by (elim φE) auto
    next
      assume "¬φ (Trans s a ou s')"
      then have "V (Trans s a ou s' # tr) = V tr" and "friends12 s' = friends12 s"
            and "UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2"
            and "UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1"
        using step_friends12_φ[OF step] step_pendingFReqs_φ[OF step] by auto
      with vVS_tr show ?thesis unfolding trn by auto
    qed
qed auto

lemma "validFrom istate tr ⟹ validValSeqFrom (V tr) istate"
using validFrom_validValSeq[of istate] reach.Istate unfolding istate_def friends12_def
by auto


subsection ‹Unwinding proof›

(* Key lemma: *)
lemma eqButUID_step_γ_out:
assumes ss1: "eqButUID s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and γ: "γ (Trans s a ou s')"
and os: "open s ⟶ friendIDs s = friendIDs s1"
shows "ou = ou1"
proof -
  from γ obtain uid where uid: "userOfA a = Some uid ∧ uid ∈ UIDs ∧ uid ≠ UID1 ∧ uid ≠ UID2
                              ∨ userOfA a = None"
    using UID1_UID2_UIDs by (cases "userOfA a") auto
  { fix uid
    assume "uid ∈∈ friendIDs s UID1 ∨ uid ∈∈ friendIDs s UID2" and "uid ∈ UIDs"
    with os have "friendIDs s = friendIDs s1" unfolding open_def openByF_def by auto
  } note fIDs = this
  { fix uid uid'
    assume uid: "uid ≠ UID1" "uid ≠ UID2"
    have "friendIDs s uid = friendIDs s1 uid" (is ?f_eq)
     and "pendingFReqs s uid = pendingFReqs s1 uid" (is ?pFR_eq)
     and "uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'" (is ?f_iff)
     and "uid ∈∈ pendingFReqs s uid' ⟷ uid ∈∈ pendingFReqs s1 uid'" (is ?pFR_iff)
     and "friendReq s uid uid' = friendReq s1 uid uid'" (is ?FR_eq)
     and "friendReq s uid' uid = friendReq s1 uid' uid" (is ?FR_eq')
    proof -
      show ?f_eq ?pFR_eq using uid ss1 UID1_UID2_UIDs unfolding eqButUID_def
        by (auto intro!: eqButUIDf_not_UID)
      show ?f_iff ?pFR_iff using uid ss1 UID1_UID2_UIDs unfolding eqButUID_def
        by (auto intro!: eqButUIDf_not_UID')
      from uid have "¬ (uid,uid') ∈ {(UID1,UID2), (UID2,UID1)}" by auto
      then show ?FR_eq ?FR_eq' using ss1 UID1_UID2_UIDs unfolding eqButUID_def
        by (auto intro!: eqButUID12_not_UID)
    qed
  } note simps = this eqButUID_def r_defs s_defs c_defs l_defs u_defs d_defs
  note facts = ss1 step step1 uid
  show ?thesis
  proof (cases a)
    case (Ract ra) then show ?thesis using facts
      apply (cases ra) by (auto simp add: simps)
  next
    case (Sact sa) then show ?thesis using facts by (cases sa) (auto simp add: simps)
  next
    case (Cact ca) then show ?thesis using facts by (cases ca) (auto simp add: simps)
  next
    case (Lact la)
      then show ?thesis using facts proof (cases la)
        case (lFriends uid p uid')
          with γ have uid: "uid ∈ UIDs" using Lact by auto
          then have uid_uid': "uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'"
            using ss1 UID1_UID2_UIDs unfolding eqButUID_def by (intro eqButUIDf_not_UID') auto
          show ?thesis
          proof (cases "(uid' = UID1 ∨ uid' = UID2) ∧ uid ∈∈ friendIDs s uid'")
            case True
              with uid have "friendIDs s = friendIDs s1" by (intro fIDs) auto
              then show ?thesis using lFriends facts Lact by (auto simp: simps)
          next
            case False
              then show ?thesis using lFriends facts Lact simps(1) uid_uid' by (auto simp: simps)
          qed
      next
        case (lPosts uid p)
          then have o: "⋀pid. owner s pid = owner s1 pid"
                and n: "⋀pid. post s pid = post s1 pid"
                and pids: "postIDs s = postIDs s1"
                and viss: "vis s = vis s1"
                and fu: "⋀uid'. uid ∈∈ friendIDs s uid' ⟷ uid ∈∈ friendIDs s1 uid'"
                and e: "e_listPosts s uid p ⟷ e_listPosts s1 uid p"
            using ss1 uid Lact unfolding eqButUID_def l_defs by (auto simp add: simps(3))
          have "listPosts s uid p = listPosts s1 uid p"
            unfolding listPosts_def o n pids fu viss ..
          with e show ?thesis using Lact lPosts step step1 by auto
      qed (auto simp add: simps)
  next
    case (Uact ua) then show ?thesis using facts by (cases ua) (auto simp add: simps)
  next
    case (Dact da) then show ?thesis using facts by (cases da) (auto simp add: simps)
  qed
qed


(* helper *) lemma produce_FRVal:
assumes rs: "reach s"
and IDs: "IDsOK s [UID1, UID2] []"
and vVS: "validValSeqFrom (FRVal u req # vl) s"
obtains a uid uid' s'
where "step s a = (outOK, s')"
  and "a = Cact (cFriendReq uid (pass s uid) uid' req)"
  and "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1"
  and "φ (Trans s a outOK s')"
  and "f (Trans s a outOK s') = FRVal u req"
  and "validValSeqFrom vl s'"
proof (cases u)
  case U1
    then have "step s (Cact (cFriendReq UID1 (pass s UID1) UID2 req)) =
                 (outOK, createFriendReq s UID1 (pass s UID1) UID2 req)"
          and "¬friends12 (createFriendReq s UID1 (pass s UID1) UID2 req)"
      using IDs vVS reach_friendIDs_symmetric[OF rs] by (auto simp: c_defs friends12_def)
    then show thesis using U1 vVS UID1_UID2 by (intro that[of _ _ UID1 UID2]) (auto simp: c_defs)
next
  case U2
    then have "step s (Cact (cFriendReq UID2 (pass s UID2) UID1 req)) =
                 (outOK, createFriendReq s UID2 (pass s UID2) UID1 req)"
          and "¬friends12 (createFriendReq s UID2 (pass s UID2) UID1 req)"
      using IDs vVS reach_friendIDs_symmetric[OF rs] by (auto simp: c_defs friends12_def)
    then show thesis using U2 vVS UID1_UID2 by (intro that[of _ _ UID2 UID1]) (auto simp: c_defs)
qed

(* helper *) lemma toggle_friends12_True:
assumes rs: "reach s"
    and IDs: "IDsOK s [UID1, UID2] []"
    and nf12: "¬friends12 s"
    and vVS: "validValSeqFrom (FVal True # vl) s"
obtains a uid uid' s'
where "step s a = (outOK, s')"
  and "a = Cact (cFriend uid (pass s uid) uid')"
  and "s' = createFriend s UID1 (pass s UID1) UID2"
  and "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1"
  and "friends12 s'"
  and "eqButUID s s'"
  and "φ (Trans s a outOK s')"
  and "f (Trans s a outOK s') = FVal True"
  and "¬γ (Trans s a outOK s')"
  and "validValSeqFrom vl s'"
proof -
  from vVS have "UID1 ∈∈ pendingFReqs s UID2 ∨ UID2 ∈∈ pendingFReqs s UID1" by auto
  then show thesis proof
    assume pFR: "UID1 ∈∈ pendingFReqs s UID2"
    let ?a = "Cact (cFriend UID2 (pass s UID2) UID1)"
    let ?s' = "createFriend s UID1 (pass s UID1) UID2"
    let ?trn = "Trans s ?a outOK ?s'"
    have step: "step s ?a = (outOK, ?s')" using IDs pFR UID1_UID2
      unfolding createFriend_sym[of "s" "UID1" "pass s UID1" "UID2" "pass s UID2"]
      by (auto simp add: c_defs)
    moreover then have "φ ?trn" and "f ?trn = FVal True" and "friends12 ?s'"
                   and "UID1 ∉ set (pendingFReqs ?s' UID2)"
                   and "UID2 ∉ set (pendingFReqs ?s' UID1)"
      using reach_distinct_friends_reqs[OF rs] by (auto simp: c_defs friends12_def)
    moreover have "¬γ ?trn" using UID1_UID2_UIDs by auto
    ultimately show thesis using nf12 rs vVS
      by (intro that[of "?a" "?s'" UID2 UID1]) (auto intro: Cact_cFriend_step_eqButUID)
  next
    assume pFR: "UID2 ∈∈ pendingFReqs s UID1"
    let ?a = "Cact (cFriend UID1 (pass s UID1) UID2)"
    let ?s' = "createFriend s UID1 (pass s UID1) UID2"
    let ?trn = "Trans s ?a outOK ?s'"
    have step: "step s ?a = (outOK, ?s')" using IDs pFR UID1_UID2 by (auto simp add: c_defs)
    moreover then have "φ ?trn" and "f ?trn = FVal True" and "friends12 ?s'"
                   and "UID1 ∉ set (pendingFReqs ?s' UID2)"
                   and "UID2 ∉ set (pendingFReqs ?s' UID1)"
      using reach_distinct_friends_reqs[OF rs] by (auto simp: c_defs friends12_def)
    moreover have "¬γ ?trn" using UID1_UID2_UIDs by auto
    ultimately show thesis using nf12 rs vVS
      by (intro that[of "?a" "?s'" UID1 UID2]) (auto intro: Cact_cFriend_step_eqButUID)
  qed
qed

(* helper *) lemma toggle_friends12_False:
assumes rs: "reach s"
    and IDs: "IDsOK s [UID1, UID2] []"
    and f12: "friends12 s"
    and vVS: "validValSeqFrom (FVal False # vl) s"
obtains a s'
where "step s a = (outOK, s')"
  and "a = Dact (dFriend UID1 (pass s UID1) UID2)"
  and "s' = deleteFriend s UID1 (pass s UID1) UID2"
  and "¬friends12 s'"
  and "eqButUID s s'"
  and "φ (Trans s a outOK s')"
  and "f (Trans s a outOK s') = FVal False"
  and "¬γ (Trans s a outOK s')"
  and "validValSeqFrom vl s'"
proof -
  let ?a = "Dact (dFriend UID1 (pass s UID1) UID2)"
  let ?s' = "deleteFriend s UID1 (pass s UID1) UID2"
  let ?trn = "Trans s ?a outOK ?s'"
  from vVS have step: "step s ?a = (outOK, ?s')"
        and "UID1 ∉ set (pendingFReqs ?s' UID2)" "UID2 ∉ set (pendingFReqs ?s' UID1)"
    using IDs f12 UID1_UID2 by (auto simp add: d_defs friends12_def)
  moreover then have "φ ?trn" and "f ?trn = FVal False" and "¬friends12 ?s'"
    by (auto simp: d_defs friends12_def)
  moreover have "¬γ ?trn" using UID1_UID2_UIDs by auto
  ultimately show thesis using f12 rs vVS
    by (intro that[of ?a ?s']) (auto intro: Dact_dFriend_step_eqButUID)
qed

lemma toggle_friends12:
assumes rs: "reach s"
    and IDs: "IDsOK s [UID1, UID2] []"
    and f12: "friends12 s ≠ fv"
    and vVS: "validValSeqFrom (FVal fv # vl) s"
obtains a s'
where "step s a = (outOK, s')"
  and "friends12 s' = fv"
  and "eqButUID s s'"
  and "φ (Trans s a outOK s')"
  and "f (Trans s a outOK s') = FVal fv"
  and "¬γ (Trans s a outOK s')"
  and "validValSeqFrom vl s'"
proof (cases "friends12 s")
  case True
    moreover then have "UID1 ∉ set (pendingFReqs s UID2)" "UID2 ∉ set (pendingFReqs s UID1)"
                   and "fv = False"
                   and vVS: "validValSeqFrom (FVal False # vl) s"
      using vVS f12 unfolding friends12_def by auto
    moreover then have "UID1 ∉ set (pendingFReqs (deleteFriend s UID1 (pass s UID1) UID2) UID2)"
                       "UID2 ∉ set (pendingFReqs (deleteFriend s UID1 (pass s UID1) UID2) UID1)"
      by (auto simp: d_defs)
    ultimately show thesis using assms
      by (elim toggle_friends12_False, blast, blast, blast) (elim that, blast+)
next
  case False
    moreover then have "fv = True"
                   and vVS: "validValSeqFrom (FVal True # vl) s"
      using vVS f12 by auto
    moreover have "UID1 ∉ set (pendingFReqs (createFriend s UID1 (pass s UID1) UID2) UID2)"
                  "UID2 ∉ set (pendingFReqs (createFriend s UID1 (pass s UID1) UID2) UID1)"
      using reach_distinct_friends_reqs[OF rs] by (auto simp: c_defs)
    ultimately show thesis using assms
      by (elim toggle_friends12_True, blast, blast, blast) (elim that, blast+)
qed


(* helper *) lemma BO_cases:
assumes "BO vl vl1"
obtains (Nil) "vl = []" and "vl1 = []"
      | (FVal) fv vl' vl1' where "vl = FVal fv # vl'" and "vl1 = FVal fv # vl1'" and "BO vl' vl1'"
      | (OVal) vl' vl1' where "vl = OVal False # vl'" and "vl1 = OVal False # vl1'" and "BC vl' vl1'"
using assms proof (cases rule: BO.cases)
  case (BO_FVal fs) then show thesis by (cases fs) (auto intro: Nil FVal) next
  case (BO_BC vl'' vl1'' fs) then show thesis by (cases fs) (auto intro: FVal OVal)
qed

(* helper *) lemma BC_cases:
assumes "BC vl vl1"
obtains (Nil) "vl = []" and "vl1 = []"
      | (FVal) fv fs where "vl = FVal fv # map FVal fs" and "vl1 = []"
      | (FVal1) fv fs fs1 where "vl = map FVal fs" and "vl1 = FVal fv # map FVal fs1"
      | (BO_FVal) fv fv' fs vl' vl1' where "vl = FVal fv # map FVal fs @ FVal fv' # OVal True # vl'"
                                       and "vl1 = FVal fv' # OVal True # vl1'" and "BO vl' vl1'"
      | (BO_FVal1) fv fv' fs fs1 vl' vl1' where "vl = map FVal fs @ FVal fv' # OVal True # vl'"
                                       and "vl1 = FVal fv # map FVal fs1 @ FVal fv' # OVal True # vl1'"
                                       and "BO vl' vl1'"
      | (FVal_BO) fv vl' vl1' where "vl = FVal fv # OVal True # vl'"
                                and "vl1 = FVal fv # OVal True # vl1'" and "BO vl' vl1'"
      | (OVal) vl' vl1' where "vl = OVal True # vl'" and "vl1 = OVal True # vl1'" and "BO vl' vl1'"
using assms proof (cases rule: BC.cases)
  case (BC_FVal fs fs1)
    then show ?thesis proof (induction fs1)
      case Nil then show ?case by (induction fs) (auto intro: that(1,2)) next
      case (Cons fv fs1') then show ?case by (intro that(3)) auto
    qed
next
  case (BC_BO vl' vl1' fs fs1)
    then show ?thesis proof (cases fs1 rule: rev_cases)
      case Nil then show ?thesis using BC_BO by (intro that(7)) auto next
      case (snoc fs1' fv')
        moreover then obtain fs' where "fs = fs' ## fv'" using BC_BO
          by (induction fs rule: rev_induct) auto
        ultimately show ?thesis using BC_BO proof (induction fs1')
          case Nil
            then show ?thesis proof (induction fs')
              case Nil then show ?thesis by (intro that(6)) auto next
              case (Cons fv'' fs'') then show ?thesis by (intro that(4)) auto
            qed
        next
          case (Cons fv'' fs1'') then show ?thesis by (intro that(5)) auto
        qed
    qed
qed


definition Δ0 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ0 s vl s1 vl1 ≡
 s = s1 ∧ B vl vl1 ∧ open s ∧ (¬IDsOK s [UID1, UID2] [])"

definition Δ1 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ1 s vl s1 vl1 ≡
 eqButUID s s1 ∧ friendIDs s = friendIDs s1 ∧ open s ∧
 BO (filter (Not o isFRVal) vl) (filter (Not o isFRVal) vl1) ∧
 validValSeqFrom vl1 s1 ∧
 IDsOK s1 [UID1, UID2] []"

definition Δ2 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ2 s vl s1 vl1 ≡ (∃fs fs1.
 eqButUID s s1 ∧ ¬open s ∧
 validValSeqFrom vl1 s1 ∧
 filter (Not o isFRVal) vl  = map FVal fs  ∧
 filter (Not o isFRVal) vl1 = map FVal fs1)"

definition Δ3 :: "state ⇒ value list ⇒ state ⇒ value list ⇒ bool" where
"Δ3 s vl s1 vl1 ≡ (∃fs fs1 vlr vlr1.
 eqButUID s s1 ∧ ¬open s ∧ BO vlr vlr1 ∧
 validValSeqFrom vl1 s1 ∧
 (fs = [] ⟷ fs1 = []) ∧
 (fs ≠ [] ⟶ last fs = last fs1) ∧
 (fs = [] ⟶ friendIDs s = friendIDs s1) ∧
 filter (Not o isFRVal) vl  = map FVal fs  @ OVal True # vlr ∧
 filter (Not o isFRVal) vl1 = map FVal fs1 @ OVal True # vlr1)"


lemma Δ2_I:
assumes "eqButUID s s1" "¬open s"
        "validValSeqFrom vl1 s1"
        "filter (Not o isFRVal) vl  = map FVal fs"
        "filter (Not o isFRVal) vl1 = map FVal fs1"
shows "Δ2 s vl s1 vl1"
using assms unfolding Δ2_def by blast

lemma Δ3_I:
assumes "eqButUID s s1" "¬open s" "BO vlr vlr1"
        "validValSeqFrom vl1 s1"
        "fs = [] ⟷ fs1 = []" "fs ≠ [] ⟶ last fs = last fs1"
        "fs = [] ⟶ friendIDs s = friendIDs s1"
        "filter (Not o isFRVal) vl  = map FVal fs  @ OVal True # vlr"
        "filter (Not o isFRVal) vl1 = map FVal fs1 @ OVal True # vlr1"
shows "Δ3 s vl s1 vl1"
using assms unfolding Δ3_def by blast


lemma istate_Δ0:
assumes B: "B vl vl1"
shows "Δ0 istate vl istate vl1"
using assms unfolding Δ0_def istate_def B_def open_def openByA_def openByF_def friends12_def
by auto

lemma unwind_cont_Δ0: "unwind_cont Δ0 {Δ0,Δ1,Δ2,Δ3}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ0 s vl s1 vl1 ∨
                           Δ1 s vl s1 vl1 ∨
                           Δ2 s vl s1 vl1 ∨
                           Δ3 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and Δ0: "Δ0 s vl s1 vl1"
  then have rs: "reach s" and ss1: "s1 = s" and B: "B vl vl1" and os: "open s"
        and IDs: "¬IDsOK s [UID1, UID2] []"
    using reachNT_reach unfolding Δ0_def by auto
  from IDs have "UID1 ∉ set (pendingFReqs s UID2)" and "¬friends12 s"
            and "UID2 ∉ set (pendingFReqs s UID1)"
    using reach_IDs_used_IDsOK[OF rs] unfolding friends12_def by auto
  with B have BO: "BO (filter (Not ∘ isFRVal) vl) (filter (Not ∘ isFRVal) vl1)"
          and vl_vl1: "vl = [] ⟶ vl1 = []"
          and vl_OVal: "vl ≠ [] ∧ hd vl = OVal False ⟶ vl1 ≠ [] ∧ hd vl1 = OVal False"
          and vVS: "validValSeqFrom vl1 s"
    unfolding B_def by (auto simp: istate_def friends12_def)
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof -
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof cases
        assume φ: "φ ?trn"
        then obtain uid p uid' p' where a: "a = Cact (cUser uid p uid' p')"
                                     "¬openByA s'" "¬openByF s'"
                                     "ou = outOK" "f ?trn = OVal False"
                                     "friends12 s' = friends12 s"
                                     "UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2"
                                     "UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1"
          using step rs IDs by (elim φE) (auto simp: openByA_def)
        with c φ have vl: "vl = OVal False # vl'" unfolding consume_def by auto
        with vl_OVal obtain vl1' where vl1: "vl1 = OVal False # vl1'" by (cases vl1) auto
        from BO vl vl1 have BC': "BC (filter (Not ∘ isFRVal) vl') (filter (Not ∘ isFRVal) vl1')"
          by (cases rule: BO_cases) auto
        then have "Δ2 s' vl' s' vl1' ∨ Δ3 s' vl' s' vl1'" using vVS a unfolding vl1
        proof (cases rule: BC.cases)
          case BC_FVal
            then show ?thesis using vVS a unfolding vl1
              by (intro disjI1 Δ2_I) (auto simp: open_def)
        next
          case BC_BO
            then show ?thesis using vVS a unfolding vl1
              by (intro disjI2 Δ3_I) (auto simp: open_def)
        qed
        then have ?match using step a φ unfolding ss1 vl1
          by (intro matchI[of s a ou s']) (auto simp: consume_def)
        then show ?thesis ..
      next
        assume nφ: "¬φ ?trn"
        then have s': "open s'" "friends12 s' = friends12 s"
                      "UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2"
                      "UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1"
          using os step_open_φ[OF step] step_friends12_φ[OF step] step_pendingFReqs_φ[OF step]
          by auto
        moreover have "vl' = vl" using nφ c by (auto simp: consume_def)
        ultimately have "Δ0 s' vl' s' vl1 ∨ Δ1 s' vl' s' vl1"
          using vVS B BO unfolding Δ0_def Δ1_def
          by (cases "IDsOK s' [UID1, UID2] []") auto
        then have ?match using step c nφ unfolding ss1
          by (intro matchI[of s a ou s']) (auto simp: consume_def)
        then show ?thesis ..
      qed
    qed
    then show ?thesis using vl_vl1 by auto
  qed
qed

lemma unwind_cont_Δ1: "unwind_cont Δ1 {Δ1,Δ2,Δ3}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ1 s vl s1 vl1 ∨
                           Δ2 s vl s1 vl1 ∨
                           Δ3 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and Δ1: "Δ1 s vl s1 vl1"
  then have rs: "reach s" and ss1: "eqButUID s s1" and fIDs: "friendIDs s = friendIDs s1"
        and os: "open s" and BO: "BO (filter (Not o isFRVal) vl) (filter (Not o isFRVal) vl1)"
        and vVS1: "validValSeq vl1 (friends12 s1)
                                   (UID1 ∈∈ pendingFReqs s1 UID2)
                                   (UID2 ∈∈ pendingFReqs s1 UID1)" (is "?vVS vl1 s1")
        and IDs1: "IDsOK s1 [UID1, UID2] []"
    using reachNT_reach unfolding Δ1_def by auto
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof cases
    assume "∃u req vl1'. vl1 = FRVal u req # vl1'"
    then obtain u req vl1' where vl1: "vl1 = FRVal u req # vl1'" by auto
    obtain a uid uid' s1' where step1: "step s1 a = (outOK, s1')" and "φ (Trans s1 a outOK s1')"
                            and a: "a = Cact (cFriendReq uid (pass s1 uid) uid' req)"
                            and uid: "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1"
                            and "f (Trans s1 a outOK s1') = FRVal u req" and "?vVS vl1' s1'"
      using rs1 IDs1 vVS1 UID1_UID2_UIDs unfolding vl1 by (blast intro: produce_FRVal)
    moreover then have "¬γ (Trans s1 a outOK s1')" using UID1_UID2_UIDs by auto
    moreover have "eqButUID s1 s1'" using step1 a uid by (auto intro: Cact_cFriendReq_step_eqButUID)
    moreover have "friendIDs s1' = friendIDs s1" and "IDsOK s1' [UID1, UID2] []"
      using step1 a uid by (auto simp: c_defs)
    ultimately have "?iact" using ss1 fIDs os BO unfolding vl1
      by (intro iactionI[of s1 a "outOK" s1']) (auto simp: consume_def Δ1_def intro: eqButUID_trans)
    then show ?thesis ..
  next
    assume nFRVal1: "¬ (∃u req vl1'. vl1 = FRVal u req # vl1')"
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof cases
        assume φ: "φ ?trn"
        then have vl: "vl = f ?trn # vl'" using c by (auto simp: consume_def)
        from BO show ?thesis proof (cases "f ?trn")
          case (FVal fv)
            with BO obtain vl1' where vl1: "vl1 = f ?trn # vl1'"
              using BO_Nil_iff[OF BO] FVal vl nFRVal1
              by (cases rule: BO_cases; cases vl1; cases "hd vl1") auto
            with BO have BO': "BO (filter (Not o isFRVal) vl') (filter (Not o isFRVal) vl1')"
              using FVal vl by (cases rule: BO_cases) auto
            from fIDs have f12: "friends12 s = friends12 s1" unfolding friends12_def by auto
            have ?match using φ step rs FVal proof (cases rule: φE)
              case (Friend uid p uid')
                then have IDs1: "IDsOK s1 [UID1, UID2] []"
                  using ss1 unfolding eqButUID_def by auto
                let ?s1' = "createFriend s1 UID1 (pass s1 UID1) UID2"
                have s': "s' = createFriend s UID1 p UID2"
                  using Friend step by (auto simp: createFriend_sym)
                have ss': "eqButUID s s'" using rs step Friend
                  by (auto intro: Cact_cFriend_step_eqButUID)
                moreover then have os': "open s'" using os eqButUID_open_eq by auto
                moreover obtain a1 uid1 uid1' p1
                where "step s1 a1 = (outOK, ?s1')" "friends12 ?s1'"
                      "a1 = Cact (cFriend uid1 p1 uid1')"
                      "uid1 = UID1 ∧ uid1' = UID2 ∨ uid1 = UID2 ∧ uid1' = UID1"
                      "φ (Trans s1 a1 outOK ?s1')"
                      "f (Trans s1 a1 outOK ?s1') = FVal True"
                      "eqButUID s1 ?s1'" "?vVS vl1' ?s1'"
                  using rs1 IDs1 Friend vVS1 unfolding vl1 f12 Friend(3)
                  by (elim toggle_friends12_True) blast+
                moreover then have "IDsOK ?s1' [UID1, UID2] []" by (auto simp: c_defs)
                moreover have "friendIDs s' = friendIDs ?s1'"
                  using Friend(6) f12 unfolding s'
                  by (intro eqButUID_createFriend12_friendIDs_eq[OF ss1 rs rs1]) auto
                ultimately show ?match using ss1 BO' Friend UID1_UID2_UIDs unfolding vl1 Δ1_def
                  by (intro matchI[of s1 a1 "outOK" ?s1'])
                     (auto simp: consume_def intro: eqButUID_trans eqButUID_sym)
            next
              case (Unfriend uid p uid')
                then have IDs1: "IDsOK s1 [UID1, UID2] []"
                  using ss1 unfolding eqButUID_def by auto
                let ?s1' = "deleteFriend s1 UID1 (pass s1 UID1) UID2"
                have s': "s' = deleteFriend s UID1 p UID2"
                  using Unfriend step by (auto simp: deleteFriend_sym)
                have ss': "eqButUID s s'" using rs step Unfriend
                  by (auto intro: Dact_dFriend_step_eqButUID)
                moreover then have os': "open s'" using os eqButUID_open_eq by auto
                moreover obtain a1 uid1 uid1' p1
                where "step s1 a1 = (outOK, ?s1')" "¬friends12 ?s1'"
                      "a1 = Dact (dFriend uid1 p1 uid1')"
                      "uid1 = UID1 ∧ uid1' = UID2 ∨ uid1 = UID2 ∧ uid1' = UID1"
                      "φ (Trans s1 a1 outOK ?s1')"
                      "f (Trans s1 a1 outOK ?s1') = FVal False"
                      "eqButUID s1 ?s1'" "?vVS vl1' ?s1'"
                  using rs1 IDs1 Unfriend vVS1 unfolding vl1 f12 Unfriend(3)
                  by (elim toggle_friends12_False) blast+
                moreover have "friendIDs s' = friendIDs ?s1'" "IDsOK ?s1' [UID1, UID2] []"
                  using fIDs IDs1 unfolding s' by (auto simp: d_defs)
                ultimately show ?match using ss1 BO' Unfriend UID1_UID2_UIDs unfolding vl1 Δ1_def
                  by (intro matchI[of s1 a1 "outOK" ?s1'])
                     (auto simp: consume_def intro: eqButUID_trans eqButUID_sym)
            qed auto
            then show ?thesis ..
        next
          case (OVal ov)
            with BO obtain vl1' where vl1': "vl1 = OVal False # vl1'"
              using BO_Nil_iff[OF BO] OVal vl nFRVal1
              by (cases rule: BO_cases; cases vl1; cases "hd vl1") auto
            with BO have BC': "BC (filter (Not o isFRVal) vl') (filter (Not o isFRVal) vl1')"
              using OVal vl by (cases rule: BO_cases) auto
            from BO vl OVal have "f ?trn = OVal False" by (cases rule: BO_cases) auto
            with φ step rs have ?match proof (cases rule: φE)
              case (CloseF uid p uid')
                let ?s1' = "deleteFriend s1 uid p uid'"
                let ?trn1 = "Trans s1 a outOK ?s1'"
                have s': "s' = deleteFriend s uid p uid'" using CloseF step by auto
                have step1: "step s1 a = (outOK, ?s1')"
                 and pFR1': "pendingFReqs ?s1' = pendingFReqs s1"
                  using CloseF step ss1 fIDs unfolding eqButUID_def by (auto simp: d_defs)
                have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                moreover have os': "¬open s'" using CloseF os unfolding open_def by auto
                moreover have fIDs': "friendIDs s' = friendIDs ?s1'"
                  using fIDs unfolding s' by (auto simp: d_defs)
                moreover have f12s1: "friends12 s1 = friends12 ?s1'"
                  using CloseF(2) UID1_UID2_UIDs unfolding friends12_def d_defs by auto
                from BC' have "Δ2 s' vl' ?s1' vl1' ∨ Δ3 s' vl' ?s1' vl1'"
                proof (cases rule: BC.cases)
                  case (BC_FVal fs fs1)
                    then show ?thesis using vVS1 os' fIDs' f12s1 s's1' pFR1'
                      unfolding Δ2_def vl1' by auto
                next
                  case (BC_BO vlr vlr1 fs fs1)
                    then have "Δ3 s' vl' ?s1' vl1'" using s's1' os' vVS1 f12s1 fIDs' pFR1'
                      unfolding vl1' by (intro Δ3_I[of _ _ _ _ _ fs fs1]) auto
                    then show ?thesis ..
                qed
                moreover have "open s1" "¬open ?s1'"
                  using ss1 os s's1' os' by (auto simp: eqButUID_open_eq)
                moreover then have "φ ?trn1" unfolding CloseF by auto
                ultimately show ?match using step1 vl1' CloseF UID1_UID2 UID1_UID2_UIDs
                  by (intro matchI[of s1 a outOK ?s1' vl1 vl1']) (auto simp: consume_def)
            next
              case (CloseA uid p uid' p')
                let ?s1' = "createUser s1 uid p uid' p'"
                let ?trn1 = "Trans s1 a outOK ?s1'"
                have s': "s' = createUser s uid p uid' p'" using CloseA step by auto
                have step1: "step s1 a = (outOK, ?s1')"
                 and pFR1': "pendingFReqs ?s1' = pendingFReqs s1"
                  using CloseA step ss1 unfolding eqButUID_def by (auto simp: c_defs)
                have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                moreover have os': "¬open s'" using CloseA os unfolding open_def by auto
                moreover have fIDs': "friendIDs s' = friendIDs ?s1'"
                  using fIDs unfolding s' by (auto simp: c_defs)
                moreover have f12s1: "friends12 s1 = friends12 ?s1'"
                  unfolding friends12_def by (auto simp: c_defs)
                from BC' have "Δ2 s' vl' ?s1' vl1' ∨ Δ3 s' vl' ?s1' vl1'"
                proof (cases rule: BC.cases)
                  case (BC_FVal fs fs1)
                    then show ?thesis using vVS1 os' fIDs' f12s1 s's1' pFR1'
                      unfolding Δ2_def vl1' by auto
                next
                  case (BC_BO vlr vlr1 fs fs1)
                    then have "Δ3 s' vl' ?s1' vl1'" using s's1' os' vVS1 f12s1 fIDs' pFR1'
                      unfolding vl1' by (intro Δ3_I[of _ _ _ _ _ fs fs1]) auto
                    then show ?thesis ..
                qed
                moreover have "open s1" "¬open ?s1'"
                  using ss1 os s's1' os' by (auto simp: eqButUID_open_eq)
                moreover then have "φ ?trn1" unfolding CloseA by auto
                ultimately show ?match using step1 vl1' CloseA UID1_UID2 UID1_UID2_UIDs
                  by (intro matchI[of s1 a outOK ?s1' vl1 vl1']) (auto simp: consume_def)
            qed auto
            then show ?thesis ..
        next
          case (FRVal u req)
            obtain p
            where a: "(a = Cact (cFriendReq UID1 p UID2 req) ∧ UID1 ∈∈ pendingFReqs s' UID2 ∧
                       UID1 ∉ set (pendingFReqs s UID2) ∧
                       (UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1)) ∨
                      (a = Cact (cFriendReq UID2 p UID1 req) ∧ UID2 ∈∈ pendingFReqs s' UID1 ∧
                       UID2 ∉ set (pendingFReqs s UID1) ∧
                       (UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2))"
                     "ou = outOK" "¬friends12 s" "¬friends12 s'" "open s' = open s"
              using φ step rs FRVal by (cases rule: φE) fastforce+
            then have fIDs': "friendIDs s' = friendIDs s" using step by (auto simp: c_defs)
            have "eqButUID s s'" using a step
              by (auto intro: Cact_cFriendReq_step_eqButUID)
            then have "Δ1 s' vl' s1 vl1"
              unfolding Δ1_def using ss1 fIDs' fIDs os a(5) vVS1 IDs1 BO vl FRVal
              by (auto intro: eqButUID_trans eqButUID_sym)
            moreover from φ step rs a have "¬γ (Trans s a ou s')"
              using UID1_UID2_UIDs by auto
            ultimately have ?ignore by (intro ignoreI) auto
            then show ?thesis ..
        qed
      next
        assume nφ: "¬φ ?trn"
        then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'"
          using step_open_φ[OF step] step_friends12_φ[OF step] by auto
        have vl': "vl' = vl" using nφ c by (auto simp: consume_def)
        show ?thesis proof (cases "∀req. a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧
                                         a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
                                         a ≠ Cact (cFriendReq UID2 (pass s UID2) UID1 req) ∧
                                         a ≠ Cact (cFriendReq UID1 (pass s UID1) UID2 req) ∧
                                         a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧
                                         a ≠ Dact (dFriend UID2 (pass s UID2) UID1)")
          case True
            obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto
            let ?trn1 = "Trans s1 a ou1 s1'"
            have fIDs': "friendIDs s' = friendIDs s1'" using True
              by (intro eqButUID_step_friendIDs_eq[OF ss1 rs rs1 step step1 _ fIDs]) auto
            from True nφ have nφ': "¬φ ?trn1" using eqButUID_step_φ[OF ss1 rs rs1 step step1] by auto
            then have f12s1': "friends12 s1 = friends12 s1'"
                  and pFRs': "UID1 ∈∈ pendingFReqs s1 UID2 ⟷ UID1 ∈∈ pendingFReqs s1' UID2"
                             "UID2 ∈∈ pendingFReqs s1 UID1 ⟷ UID2 ∈∈ pendingFReqs s1' UID1"
              using step_friends12_φ[OF step1] step_pendingFReqs_φ[OF step1]
              by auto
            have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
            then have "Δ1 s' vl' s1' vl1" using os fIDs' vVS1 BO IDsOK_mono[OF step1 IDs1]
              unfolding Δ1_def os' f12s1' pFRs' vl' by auto
            then have ?match
              using step1 nφ' fIDs eqButUID_step_γ_out[OF ss1 step step1]
              by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def)
            then show "?match ∨ ?ignore" ..
        next
          case False
            with nφ have "ou ≠ outOK" by auto
            then have "s' = s" using step False by auto
            then have ?ignore using Δ1 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto
            then show "?match ∨ ?ignore" ..
        qed
      qed
    qed
    moreover have "vl = [] ⟶ vl1 = []" proof
      assume "vl = []"
      with BO have "filter (Not ∘ isFRVal) vl1 = []" using BO_Nil_iff[OF BO] by auto
      with nFRVal1 show "vl1 = []" by (cases vl1; cases "hd vl1") auto
    qed
    ultimately show ?thesis by auto
  qed
qed

lemma unwind_cont_Δ2: "unwind_cont Δ2 {Δ2, Δ1}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ2 s vl s1 vl1 ∨ Δ1 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and 2: "Δ2 s vl s1 vl1"
  from rsT have rs: "reach s" by (intro reachNT_reach)
  from 2 obtain fs fs1
  where ss1: "eqButUID s s1" and os: "¬open s"
    and vVS1: "validValSeqFrom vl1 s1"
    and fs:  "filter (Not o isFRVal) vl =  map FVal fs"
    and fs1: "filter (Not o isFRVal) vl1 = map FVal fs1"
    unfolding Δ2_def by auto
  from os have IDs: "IDsOK s [UID1, UID2] []" unfolding open_defs by auto
  then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof cases
    assume vl1: "vl1 = []"
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
      show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
      proof cases
        assume φ: "φ ?trn"
        with c have vl: "vl = f ?trn # vl'" by (auto simp: consume_def)
        with fs have ?ignore proof (cases "f ?trn")
          case (FRVal u req)
            obtain p
            where a: "(a = Cact (cFriendReq UID1 p UID2 req) ∧ UID1 ∈∈ pendingFReqs s' UID2 ∧
                       UID1 ∉ set (pendingFReqs s UID2) ∧
                       (UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1)) ∨
                      (a = Cact (cFriendReq UID2 p UID1 req) ∧ UID2 ∈∈ pendingFReqs s' UID1 ∧
                       UID2 ∉ set (pendingFReqs s UID1) ∧
                       (UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2))"
                     "ou = outOK" "¬friends12 s" "¬friends12 s'" "open s' = open s"
              using φ step rs FRVal by (cases rule: φE) fastforce+
            then have fIDs': "friendIDs s' = friendIDs s" using step by (auto simp: c_defs)
            have "eqButUID s s'" using a step
              by (auto intro: Cact_cFriendReq_step_eqButUID)
            then have "Δ2 s' vl' s1 vl1"
              unfolding Δ2_def using ss1 os a(5) vVS1 vl fs fs1
              by (auto intro: eqButUID_trans eqButUID_sym)
            moreover from φ step rs a have "¬γ (Trans s a ou s')"
              using UID1_UID2_UIDs by auto
            ultimately show ?ignore by (intro ignoreI) auto
        next
          case (FVal fv)
            with fs vl obtain fs' where fs': "fs = fv # fs'" by (cases fs) auto
            from φ step rs FVal have ss': "eqButUID s s'"
              by (elim φE) (auto intro: Cact_cFriend_step_eqButUID Dact_dFriend_step_eqButUID)
            then have "¬open s'" using os by (auto simp: eqButUID_open_eq)
            moreover have "eqButUID s' s1" using ss1 ss' by (auto intro: eqButUID_sym eqButUID_trans)
            ultimately have "Δ2 s' vl' s1 vl1"
              using vVS1 fs' fs unfolding Δ2_def vl vl1 FVal by auto
            moreover have "¬γ ?trn" using φ step rs FVal UID1_UID2_UIDs by (elim φE) auto
            ultimately show ?ignore by (intro ignoreI) auto
        qed auto
        then show ?thesis ..
      next
        assume nφ: "¬φ ?trn"
        then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'"
          using step_open_φ[OF step] step_friends12_φ[OF step] by auto
        have vl': "vl' = vl" using nφ c by (auto simp: consume_def)
        show ?thesis proof (cases "∀req. a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧
                                         a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
                                         a ≠ Cact (cFriendReq UID2 (pass s UID2) UID1 req) ∧
                                         a ≠ Cact (cFriendReq UID1 (pass s UID1) UID2 req) ∧
                                         a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧
                                         a ≠ Dact (dFriend UID2 (pass s UID2) UID1)")
          case True
            obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto
            let ?trn1 = "Trans s1 a ou1 s1'"
            from True nφ have nφ': "¬φ ?trn1"
              using eqButUID_step_φ[OF ss1 rs rs1 step step1] by auto
            then have f12s1': "friends12 s1 = friends12 s1'"
                  and pFRs': "UID1 ∈∈ pendingFReqs s1 UID2 ⟷ UID1 ∈∈ pendingFReqs s1' UID2"
                             "UID2 ∈∈ pendingFReqs s1 UID1 ⟷ UID2 ∈∈ pendingFReqs s1' UID1"
              using step_friends12_φ[OF step1] step_pendingFReqs_φ[OF step1]
              by auto
            have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
            then have "Δ2 s' vl' s1' vl1" using os vVS1 fs fs1
              unfolding Δ2_def os' f12s1' pFRs' vl' by auto
            then have ?match
              using step1 nφ' os eqButUID_step_γ_out[OF ss1 step step1]
              by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def)
            then show "?match ∨ ?ignore" ..
        next
          case False
            with nφ have "ou ≠ outOK" by auto
            then have "s' = s" using step False by auto
            then have ?ignore using 2 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto
            then show "?match ∨ ?ignore" ..
        qed
      qed
    qed
    then show ?thesis using vl1 by auto
  next
    assume "vl1 ≠ []"
    then obtain v vl1' where vl1: "vl1 = v # vl1'" by (cases vl1) auto
    with fs1 have ?iact proof (cases v)
      case (FRVal u req)
        obtain a uid uid' s1' where step1: "step s1 a = (outOK, s1')" and "φ (Trans s1 a outOK s1')"
                                and a: "a = Cact (cFriendReq uid (pass s1 uid) uid' req)"
                                and uid: "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1"
                                and "f (Trans s1 a outOK s1') = FRVal u req"
                                and vVS1': "validValSeqFrom vl1' s1'"
          using rs1 IDs1 vVS1 UID1_UID2_UIDs unfolding vl1 FRVal by (blast intro: produce_FRVal)
        moreover then have "¬γ (Trans s1 a outOK s1')" using UID1_UID2_UIDs by auto
        moreover have "eqButUID s1 s1'" using step1 a uid
          by (auto intro: Cact_cFriendReq_step_eqButUID)
        moreover then have "Δ2 s vl s1' vl1'" using ss1 os vVS1' fs fs1 unfolding vl1 FRVal
          by (intro Δ2_I[of s s1' vl1' vl fs fs1]) (auto intro: eqButUID_trans)
        ultimately show "?iact" using ss1 os unfolding vl1 FRVal
          by (intro iactionI[of s1 a "outOK" s1']) (auto simp: consume_def intro: eqButUID_trans)
    next
      case (FVal fv)
        then obtain fs1' where fs1': "fs1 = fv # fs1'"
          using vl1 fs1 by (cases fs1) auto
        from FVal vVS1 vl1 have f12: "friends12 s1 ≠ fv"
                            and vVS1: "validValSeqFrom (FVal fv # vl1') s1" by auto
        then show ?iact using rs1 IDs1 vl1 FVal ss1 os fs fs1 fs1' vl1 FVal
          by (elim toggle_friends12[of s1 fv vl1'], blast, blast, blast)
             (intro iactionI[of s1 _ _ _ vl1 vl1'],
              auto simp: consume_def intro: Δ2_I[of s _ vl1' vl fs fs1'] eqButUID_trans)
    qed auto
    then show ?thesis ..
  qed
qed


lemma unwind_cont_Δ3: "unwind_cont Δ3 {Δ3,Δ1}"
proof(rule, simp)
  let ?Δ = "λs vl s1 vl1. Δ3 s vl s1 vl1 ∨ Δ1 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and 3: "Δ3 s vl s1 vl1"
  from rsT have rs: "reach s" by (intro reachNT_reach)
  obtain fs fs1 vlr vlr1
  where ss1: "eqButUID s s1" and os: "¬open s" and BO: "BO vlr vlr1"
    and vVS1: "validValSeqFrom vl1 s1"
    and fs:  "filter (Not o isFRVal) vl =  map FVal fs  @ OVal True # vlr"
    and fs1: "filter (Not o isFRVal) vl1 = map FVal fs1 @ OVal True # vlr1"
    and fs_fs1: "fs = [] ⟷ fs1 = []"
    and last_fs: "fs ≠ [] ⟶ last fs = last fs1"
    and fs_fIDs: "fs = [] ⟶ friendIDs s = friendIDs s1"
    using 3 unfolding Δ3_def by auto
  have BC: "BC (map FVal fs @ OVal True # vlr) (map FVal fs1 @ OVal True # vlr1)"
    using fs fs1 fs_fs1 last_fs BO by auto
  from os have IDs: "IDsOK s [UID1, UID2] []" unfolding open_defs by auto
  then have IDs1: "IDsOK s1 [UID1, UID2] []" using ss1 unfolding eqButUID_def by auto
  show "iaction ?Δ s vl s1 vl1 ∨
        ((vl = [] ⟶ vl1 = []) ∧ reaction ?Δ s vl s1 vl1)" (is "?iact ∨ (_ ∧ ?react)")
  proof cases
    assume "∃u req vl1'. vl1 = FRVal u req # vl1'"
    then obtain u req vl1' where vl1: "vl1 = FRVal u req # vl1'" by auto
    obtain a uid uid' s1' where step1: "step s1 a = (outOK, s1')" and φ: "φ (Trans s1 a outOK s1')"
                            and a: "a = Cact (cFriendReq uid (pass s1 uid) uid' req)"
                            and uid: "uid = UID1 ∧ uid' = UID2 ∨ uid = UID2 ∧ uid' = UID1"
                            and f: "f (Trans s1 a outOK s1') = FRVal u req"
                            and "validValSeqFrom vl1' s1'"
      using rs1 IDs1 vVS1 UID1_UID2_UIDs unfolding vl1 by (blast intro: produce_FRVal)
    moreover have "eqButUID s1 s1'" using step1 a uid by (auto intro: Cact_cFriendReq_step_eqButUID)
    moreover have "friendIDs s1' = friendIDs s1" and "IDsOK s1' [UID1, UID2] []"
      using step1 a uid by (auto simp: c_defs)
    ultimately have "Δ3 s vl s1' vl1'" using ss1 os BO fs_fs1 last_fs fs_fIDs fs fs1 unfolding vl1
      by (intro Δ3_I[of _ _ vlr vlr1 vl1' fs fs1 vl])
         (auto simp: consume_def intro: eqButUID_trans)
    moreover have "¬γ (Trans s1 a outOK s1')" using a uid UID1_UID2_UIDs by auto
    ultimately have "?iact" using step1 φ f unfolding vl1
      by (intro iactionI[of s1 a "outOK" s1']) (auto simp: consume_def)
    then show ?thesis ..
  next
    assume nFRVal1: "¬(∃u req vl1'. vl1 = FRVal u req # vl1')"
    from BC show ?thesis proof (cases rule: BC_cases)
      case (BO_FVal fv fv' fs' vl'' vl1'')
        then have fs': "filter (Not o isFRVal) vl = map FVal (fv # fs' ## fv') @ OVal True # vl''"
              and fs1': "filter (Not o isFRVal) vl1 = FVal fv' # OVal True # vl1''"
          using fs fs1 by auto
        have ?react proof
          fix a :: act and ou :: out and s' :: state and vl'
          let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
          assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
          show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
          proof cases
            assume φ: "φ ?trn"
            with c have vl: "vl = f ?trn # vl'" by (auto simp: consume_def)
            with fs' have ?ignore proof (cases "f ?trn")
              case (FRVal u req)
                obtain p
                where a: "(a = Cact (cFriendReq UID1 p UID2 req) ∧ UID1 ∈∈ pendingFReqs s' UID2 ∧
                           UID1 ∉ set (pendingFReqs s UID2) ∧
                           (UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1)) ∨
                          (a = Cact (cFriendReq UID2 p UID1 req) ∧ UID2 ∈∈ pendingFReqs s' UID1 ∧
                           UID2 ∉ set (pendingFReqs s UID1) ∧
                           (UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2))"
                         "ou = outOK" "¬friends12 s" "¬friends12 s'" "open s' = open s"
                  using φ step rs FRVal by (cases rule: φE) fastforce+
                then have fIDs': "friendIDs s' = friendIDs s" using step by (auto simp: c_defs)
                have "eqButUID s s'" using a step
                  by (auto intro: Cact_cFriendReq_step_eqButUID)
                then have "Δ3 s' vl' s1 vl1"
                  using ss1 a os BO vVS1 fs_fs1 last_fs fs_fIDs fs fs1 fIDs' vl FRVal
                  by (intro Δ3_I[of s' s1 vlr vlr1 vl1 fs fs1 vl'])
                     (auto intro: eqButUID_trans eqButUID_sym)
                moreover from a have "¬γ (Trans s a ou s')"
                  using UID1_UID2_UIDs by auto
                ultimately show ?ignore by (intro ignoreI) auto
            next
              case (FVal fv'')
                with vl fs' have FVal: "f ?trn = FVal fv"
                             and vl': "filter (Not ∘ isFRVal) vl' = map FVal (fs' ## fv') @ OVal True # vl''"
                  by auto
                from φ step rs FVal have ss': "eqButUID s s'"
                  by (elim φE) (auto intro: Cact_cFriend_step_eqButUID Dact_dFriend_step_eqButUID)
                then have "¬open s'" using os by (auto simp: eqButUID_open_eq)
                moreover have "eqButUID s' s1" using ss1 ss' by (auto intro: eqButUID_sym eqButUID_trans)
                ultimately have "Δ3 s' vl' s1 vl1" using BO_FVal(3) vVS1 vl' fs1'
                  by (intro Δ3_I[of s' s1 vl'' vl1'' vl1 "fs' ## fv'" "[fv']" vl']) auto
                moreover have "¬γ ?trn" using φ step rs FVal UID1_UID2_UIDs by (elim φE) auto
                ultimately show ?ignore by (intro ignoreI) auto
            qed auto
            then show ?thesis ..
          next
            assume nφ: "¬φ ?trn"
            then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'"
              using step_open_φ[OF step] step_friends12_φ[OF step] by auto
            have vl': "vl' = vl" using nφ c by (auto simp: consume_def)
            show ?thesis proof (cases "∀req. a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧
                                             a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
                                             a ≠ Cact (cFriendReq UID2 (pass s UID2) UID1 req) ∧
                                             a ≠ Cact (cFriendReq UID1 (pass s UID1) UID2 req) ∧
                                             a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧
                                             a ≠ Dact (dFriend UID2 (pass s UID2) UID1)")
              case True
                obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto
                let ?trn1 = "Trans s1 a ou1 s1'"
                from True nφ have nφ': "¬φ ?trn1"
                  using eqButUID_step_φ[OF ss1 rs rs1 step step1] by auto
                then have f12s1': "friends12 s1 = friends12 s1'"
                      and pFRs': "UID1 ∈∈ pendingFReqs s1 UID2 ⟷ UID1 ∈∈ pendingFReqs s1' UID2"
                                 "UID2 ∈∈ pendingFReqs s1 UID1 ⟷ UID2 ∈∈ pendingFReqs s1' UID1"
                  using step_friends12_φ[OF step1] step_pendingFReqs_φ[OF step1]
                  by auto
                have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                thm Δ3_I[of s' s1' vl'' vl1'' vl1 "fv # fs' ## fv'" "[fv']" vl']
                then have "Δ3 s' vl' s1' vl1" using os vVS1 fs' fs1' BO_FVal
                  unfolding os' f12s1' pFRs' vl'
                  by (intro Δ3_I[of s' s1' vl'' vl1'' vl1 "fv # fs' ## fv'" "[fv']" vl]) auto
                then have ?match
                  using step1 nφ' os eqButUID_step_γ_out[OF ss1 step step1]
                  by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def)
                then show "?match ∨ ?ignore" ..
            next
              case False
                with nφ have "ou ≠ outOK" by auto
                then have "s' = s" using step False by auto
                then have ?ignore using 3 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto
                then show "?match ∨ ?ignore" ..
            qed
          qed
        qed
        then show ?thesis using fs' by auto
    next
      case (BO_FVal1 fv fv' fs' fs1' vl'' vl1'')
        then have fs': "filter (Not o isFRVal) vl = map FVal (fs' ## fv') @ OVal True # vl''"
              and fs1': "filter (Not o isFRVal) vl1 = map FVal (fv # fs1' ## fv') @ OVal True # vl1''"
          using fs fs1 by auto
        with nFRVal1 obtain vl1'
        where vl1: "vl1 = FVal fv # vl1'"
          and vl1': "filter (Not o isFRVal) vl1' = map FVal (fs1' ## fv') @ OVal True # vl1''"
          by (cases vl1; cases "hd vl1") auto
        with vVS1 have f12: "friends12 s1 ≠ fv"
                   and vVS1: "validValSeqFrom (FVal fv # vl1') s1" by auto
        then have ?iact using rs1 IDs1 vl1 ss1 os BO_FVal1(3) fs' vl1'
          by (elim toggle_friends12[of s1 fv vl1'], blast, blast, blast)
             (intro iactionI[of s1 _ _ _ vl1 vl1'],
              auto simp: consume_def
                   intro: Δ3_I[of s _ vl'' vl1'' vl1' "fs' ## fv'" "fs1' ## fv'" vl]
                          eqButUID_trans)
        then show ?thesis ..
    next
      case (FVal_BO fv vl'' vl1'')
        then have fs': "filter (Not o isFRVal) vl = FVal fv # OVal True # vl''"
              and fs1': "filter (Not o isFRVal) vl1 = FVal fv # OVal True # vl1''"
          using fs fs1 by auto
        have ?react proof
          fix a :: act and ou :: out and s' :: state and vl'
          let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
          assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
          show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
          proof cases
            assume φ: "φ ?trn"
            with c have vl: "vl = f ?trn # vl'" by (auto simp: consume_def)
            with fs' show ?thesis proof (cases "f ?trn")
              case (FRVal u req)
                obtain p
                where a: "(a = Cact (cFriendReq UID1 p UID2 req) ∧ UID1 ∈∈ pendingFReqs s' UID2 ∧
                           UID1 ∉ set (pendingFReqs s UID2) ∧
                           (UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1)) ∨
                          (a = Cact (cFriendReq UID2 p UID1 req) ∧ UID2 ∈∈ pendingFReqs s' UID1 ∧
                           UID2 ∉ set (pendingFReqs s UID1) ∧
                           (UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2))"
                         "ou = outOK" "¬friends12 s" "¬friends12 s'" "open s' = open s"
                  using φ step rs FRVal by (cases rule: φE) fastforce+
                then have fIDs': "friendIDs s' = friendIDs s" using step by (auto simp: c_defs)
                have "eqButUID s s'" using a step
                  by (auto intro: Cact_cFriendReq_step_eqButUID)
                then have "Δ3 s' vl' s1 vl1"
                  using ss1 a os BO vVS1 fs_fs1 last_fs fs_fIDs fs fs1 fIDs' vl FRVal
                  by (intro Δ3_I[of s' s1 vlr vlr1 vl1 fs fs1 vl'])
                     (auto intro: eqButUID_trans eqButUID_sym)
                moreover from a have "¬γ (Trans s a ou s')"
                  using UID1_UID2_UIDs by auto
                ultimately have ?ignore by (intro ignoreI) auto
                then show ?thesis ..
            next
              case (FVal fv'')
                with vl fs' have FVal: "f ?trn = FVal fv"
                             and vl': "filter (Not ∘ isFRVal) vl' = OVal True # vl''"
                  by auto
                from fs1' nFRVal1 obtain vl1'
                where vl1: "vl1 = FVal fv # vl1'"
                  and vl1': "filter (Not ∘ isFRVal) vl1' = OVal True # vl1''"
                  by (cases vl1; cases "hd vl1") auto
                have ?match using φ step rs FVal proof (cases rule: φE)
                  case (Friend uid p uid')
                    then have IDs1: "IDsOK s1 [UID1, UID2] []"
                          and f12s1: "¬friends12 s1"
                          and fv: "fv = True"
                      using ss1 vVS1 FVal unfolding eqButUID_def vl1 by auto
                    let ?s1' = "createFriend s1 UID1 (pass s1 UID1) UID2"
                    have s': "s' = createFriend s UID1 p UID2"
                      using Friend step by (auto simp: createFriend_sym)
                    have ss': "eqButUID s s'" using rs step Friend
                      by (auto intro: Cact_cFriend_step_eqButUID)
                    moreover then have os': "¬open s'" using os eqButUID_open_eq by auto
                    moreover obtain a1 uid1 uid1' p1
                    where "step s1 a1 = (outOK, ?s1')" "friends12 ?s1'"
                          "a1 = Cact (cFriend uid1 p1 uid1')"
                          "uid1 = UID1 ∧ uid1' = UID2 ∨ uid1 = UID2 ∧ uid1' = UID1"
                          "φ (Trans s1 a1 outOK ?s1')"
                          "f (Trans s1 a1 outOK ?s1') = FVal True"
                          "eqButUID s1 ?s1'" "validValSeqFrom vl1' ?s1'"
                      using rs1 IDs1 Friend vVS1 f12s1 unfolding vl1 FVal
                      by (elim toggle_friends12_True; blast)
                    moreover then have "IDsOK ?s1' [UID1, UID2] []" by (auto simp: c_defs)
                    moreover have "friendIDs s' = friendIDs ?s1'"
                      using Friend(6) f12s1 unfolding s'
                      by (intro eqButUID_createFriend12_friendIDs_eq[OF ss1 rs rs1]) auto
                    ultimately show ?match
                      using ss1 FVal_BO Friend UID1_UID2_UIDs vl' vl1' unfolding vl1 fv
                      by (intro matchI[of s1 a1 "outOK" ?s1'])
                         (auto simp: consume_def intro: eqButUID_trans eqButUID_sym
                               intro!: Δ3_I[of s' ?s1' vl'' vl1'' vl1' "[]" "[]" vl'])
                next
                  case (Unfriend uid p uid')
                    then have IDs1: "IDsOK s1 [UID1, UID2] []"
                          and f12s1: "friends12 s1"
                          and fv: "fv = False"
                      using ss1 vVS1 FVal unfolding eqButUID_def vl1 by auto
                    let ?s1' = "deleteFriend s1 UID1 (pass s1 UID1) UID2"
                    have s': "s' = deleteFriend s UID1 p UID2"
                      using Unfriend step by (auto simp: deleteFriend_sym)
                    have ss': "eqButUID s s'" using rs step Unfriend
                      by (auto intro: Dact_dFriend_step_eqButUID)
                    moreover then have os': "¬open s'" using os eqButUID_open_eq by auto
                    moreover obtain a1 uid1 uid1' p1
                    where "step s1 a1 = (outOK, ?s1')" "¬friends12 ?s1'"
                          "a1 = Dact (dFriend uid1 p1 uid1')"
                          "uid1 = UID1 ∧ uid1' = UID2 ∨ uid1 = UID2 ∧ uid1' = UID1"
                          "φ (Trans s1 a1 outOK ?s1')"
                          "f (Trans s1 a1 outOK ?s1') = FVal False"
                          "eqButUID s1 ?s1'" "validValSeqFrom vl1' ?s1'"
                      using rs1 IDs1 Unfriend vVS1 f12s1 unfolding vl1 FVal
                      by (elim toggle_friends12_False; blast)
                    moreover then have "IDsOK ?s1' [UID1, UID2] []" by (auto simp: d_defs)
                    moreover have "friendIDs s' = friendIDs ?s1'"
                      using Unfriend(6) f12s1 unfolding s'
                      by (intro eqButUID_deleteFriend12_friendIDs_eq[OF ss1 rs rs1])
                    ultimately show ?match
                      using ss1 FVal_BO Unfriend UID1_UID2_UIDs vl' vl1' unfolding vl1 fv
                      by (intro matchI[of s1 a1 "outOK" ?s1'])
                         (auto simp: consume_def intro: eqButUID_trans eqButUID_sym
                               intro!: Δ3_I[of s' ?s1' vl'' vl1'' vl1' "[]" "[]" vl'])
                qed auto
                then show ?thesis ..
            qed auto
          next
            assume nφ: "¬φ ?trn"
            then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'"
              using step_open_φ[OF step] step_friends12_φ[OF step] by auto
            have vl': "vl' = vl" using nφ c by (auto simp: consume_def)
            show ?thesis proof (cases "∀req. a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧
                                             a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
                                             a ≠ Cact (cFriendReq UID2 (pass s UID2) UID1 req) ∧
                                             a ≠ Cact (cFriendReq UID1 (pass s UID1) UID2 req) ∧
                                             a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧
                                             a ≠ Dact (dFriend UID2 (pass s UID2) UID1)")
              case True
                obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto
                let ?trn1 = "Trans s1 a ou1 s1'"
                from True nφ have nφ': "¬φ ?trn1"
                  using eqButUID_step_φ[OF ss1 rs rs1 step step1] by auto
                then have f12s1': "friends12 s1 = friends12 s1'"
                      and pFRs': "UID1 ∈∈ pendingFReqs s1 UID2 ⟷ UID1 ∈∈ pendingFReqs s1' UID2"
                                 "UID2 ∈∈ pendingFReqs s1 UID1 ⟷ UID2 ∈∈ pendingFReqs s1' UID1"
                  using step_friends12_φ[OF step1] step_pendingFReqs_φ[OF step1]
                  by auto
                have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                thm Δ3_I[of s' s1' vl'' vl1'' vl1 "[fv]" "[fv]" vl']
                then have "Δ3 s' vl' s1' vl1" using os vVS1 fs' fs1' FVal_BO
                  unfolding os' f12s1' pFRs' vl'
                  by (intro Δ3_I[of s' s1' vl'' vl1'' vl1 "[fv]" "[fv]" vl]) auto
                then have ?match
                  using step1 nφ' os eqButUID_step_γ_out[OF ss1 step step1]
                  by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def)
                then show "?match ∨ ?ignore" ..
            next
              case False
                with nφ have "ou ≠ outOK" by auto
                then have "s' = s" using step False by auto
                then have ?ignore using 3 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto
                then show "?match ∨ ?ignore" ..
            qed
          qed
        qed
        then show ?thesis using fs' by auto
    next
      case (OVal vl'' vl1'')
        then have fs': "filter (Not o isFRVal) vl = OVal True # vl''"
              and fs1': "filter (Not o isFRVal) vl1 = OVal True # vl1''"
              and BO'': "BO vl'' vl1''"
          using fs fs1 by auto
        from fs fs' have fs: "fs = []" by (cases fs) auto
        with fs_fIDs have fIDs: "friendIDs s = friendIDs s1" by auto
        have ?react proof
          fix a :: act and ou :: out and s' :: state and vl'
          let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
          assume step: "step s a = (ou, s')" and T: "¬ T ?trn" and c: "consume ?trn vl vl'"
          show "match ?Δ s s1 vl1 a ou s' vl' ∨ ignore ?Δ s s1 vl1 a ou s' vl'" (is "?match ∨ ?ignore")
          proof cases
            assume φ: "φ ?trn"
            with c have vl: "vl = f ?trn # vl'" by (auto simp: consume_def)
            with fs' show ?thesis proof (cases "f ?trn")
              case (FRVal u req)
                obtain p
                where a: "(a = Cact (cFriendReq UID1 p UID2 req) ∧ UID1 ∈∈ pendingFReqs s' UID2 ∧
                           UID1 ∉ set (pendingFReqs s UID2) ∧
                           (UID2 ∈∈ pendingFReqs s' UID1 ⟷ UID2 ∈∈ pendingFReqs s UID1)) ∨
                          (a = Cact (cFriendReq UID2 p UID1 req) ∧ UID2 ∈∈ pendingFReqs s' UID1 ∧
                           UID2 ∉ set (pendingFReqs s UID1) ∧
                           (UID1 ∈∈ pendingFReqs s' UID2 ⟷ UID1 ∈∈ pendingFReqs s UID2))"
                         "ou = outOK" "¬friends12 s" "¬friends12 s'" "open s' = open s"
                  using φ step rs FRVal by (cases rule: φE) fastforce+
                then have fIDs': "friendIDs s' = friendIDs s" using step by (auto simp: c_defs)
                have "eqButUID s s'" using a step
                  by (auto intro: Cact_cFriendReq_step_eqButUID)
                then have "Δ3 s' vl' s1 vl1"
                  using ss1 a os OVal(3) vVS1 fs' fs1' fs fs_fs1 fIDs' fIDs unfolding vl FRVal
                  by (intro Δ3_I[of s' s1 vl'' vl1'' vl1 fs fs1 vl'])
                     (auto intro: eqButUID_trans eqButUID_sym)
                moreover from φ step rs a have "¬γ (Trans s a ou s')"
                  using UID1_UID2_UIDs by auto
                ultimately have ?ignore by (intro ignoreI) auto
                then show ?thesis ..
            next
              case (OVal ov')
                with vl fs' have OVal: "f ?trn = OVal True"
                             and vl': "filter (Not ∘ isFRVal) vl' = vl''"
                  by auto
                from fs1' nFRVal1 obtain vl1'
                where vl1: "vl1 = OVal True # vl1'"
                  and vl1': "filter (Not ∘ isFRVal) vl1' = vl1''"
                  by (cases vl1; cases "hd vl1") auto
                have ?match using φ step rs OVal proof (cases rule: φE)
                  case (OpenF uid p uid')
                    let ?s1' = "createFriend s1 uid p uid'"
                    have s': "s' = createFriend s uid p uid'"
                      using OpenF step by auto
                    from OpenF(2) have uids: "uid ≠ UID1 ∧ uid ≠ UID2 ∧ uid' = UID1 ∨
                                        uid ≠ UID1 ∧ uid ≠ UID2 ∧ uid' = UID2 ∨
                                        uid' ≠ UID1 ∧ uid' ≠ UID2 ∧ uid = UID1 ∨
                                        uid' ≠ UID1 ∧ uid' ≠ UID2 ∧ uid = UID2"
                      using UID1_UID2_UIDs by auto
                    have "eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
                      using ss1 unfolding eqButUID_def by auto
                    then have "uid' ∈∈ pendingFReqs s uid ⟷ uid' ∈∈ pendingFReqs s1 uid"
                      using OpenF by (intro eqButUIDf_not_UID') auto
                    then have step1: "step s1 a = (outOK, ?s1')"
                      using OpenF step ss1 fIDs unfolding eqButUID_def by (auto simp: c_defs)
                    have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                    moreover have os': "open s'" using OpenF unfolding open_def by auto
                    moreover have fIDs': "friendIDs s' = friendIDs ?s1'"
                      using fIDs unfolding s' by (auto simp: c_defs)
                    moreover have f12s1: "friends12 s1 = friends12 ?s1'"
                                  "UID1 ∈∈ pendingFReqs s1 UID2 ⟷ UID1 ∈∈ pendingFReqs ?s1' UID2"
                                  "UID2 ∈∈ pendingFReqs s1 UID1 ⟷ UID2 ∈∈ pendingFReqs ?s1' UID1"
                      using uids unfolding friends12_def c_defs by auto
                    moreover then have "validValSeqFrom vl1' ?s1'" using vVS1 unfolding vl1 by auto
                    ultimately have "Δ1 s' vl' ?s1' vl1'"
                      using BO'' IDsOK_mono[OF step1 IDs1] unfolding Δ1_def vl' vl1' by auto
                    moreover have "φ ?trn ⟷ φ (Trans s1 a outOK ?s1')"
                      using OpenF(1) uids by (intro eqButUID_step_φ[OF ss1 rs rs1 step step1]) auto
                    ultimately show ?match using step1 φ OpenF(1,3,4) unfolding vl1
                      by (intro matchI[of s1 a outOK ?s1' _ vl1']) (auto simp: consume_def)
                qed auto
                then show ?thesis ..
            qed auto
        next
          assume nφ: "¬φ ?trn"
            then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'"
              using step_open_φ[OF step] step_friends12_φ[OF step] by auto
            have vl': "vl' = vl" using nφ c by (auto simp: consume_def)
            show ?thesis proof (cases "∀req. a ≠ Cact (cFriend UID1 (pass s UID1) UID2) ∧
                                             a ≠ Cact (cFriend UID2 (pass s UID2) UID1) ∧
                                             a ≠ Cact (cFriendReq UID2 (pass s UID2) UID1 req) ∧
                                             a ≠ Cact (cFriendReq UID1 (pass s UID1) UID2 req) ∧
                                             a ≠ Dact (dFriend UID1 (pass s UID1) UID2) ∧
                                             a ≠ Dact (dFriend UID2 (pass s UID2) UID1)")
              case True
                obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto
                let ?trn1 = "Trans s1 a ou1 s1'"
                from True nφ have nφ': "¬φ ?trn1"
                  using eqButUID_step_φ[OF ss1 rs rs1 step step1] by auto
                then have f12s1': "friends12 s1 = friends12 s1'"
                      and pFRs': "UID1 ∈∈ pendingFReqs s1 UID2 ⟷ UID1 ∈∈ pendingFReqs s1' UID2"
                                 "UID2 ∈∈ pendingFReqs s1 UID1 ⟷ UID2 ∈∈ pendingFReqs s1' UID1"
                  using step_friends12_φ[OF step1] step_pendingFReqs_φ[OF step1]
                  by auto
                have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                moreover have "friendIDs s' = friendIDs s1'"
                  using eqButUID_step_friendIDs_eq[OF ss1 rs rs1 step step1 _ fIDs] True
                  by auto
                ultimately have "Δ3 s' vl' s1' vl1" using os vVS1 fs' fs1' OVal
                  unfolding os' f12s1' pFRs' vl'
                  by (intro Δ3_I[of s' s1' vl'' vl1'' vl1 "[]" "[]" vl]) auto
                then have ?match
                  using step1 nφ' os eqButUID_step_γ_out[OF ss1 step step1]
                  by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def)
                then show "?match ∨ ?ignore" ..
            next
              case False
                with nφ have "ou ≠ outOK" by auto
                then have "s' = s" using step False by auto
                then have ?ignore using 3 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto
                then show "?match ∨ ?ignore" ..
            qed
          qed
        qed
        then show ?thesis using fs' by auto
    next
      case (FVal1 fv fs' fs1')
        from this(1) have "False" proof (induction fs' arbitrary: fs)
          case (Cons fv'' fs'')
            then obtain fs''' where "map FVal (fv'' # fs''') @ OVal True # vlr = map FVal (fv'' # fs'')"
              by (cases fs) auto
            with Cons.IH[of fs'''] show "False" by auto
        qed auto
        then show ?thesis ..
    next
      case (FVal) then show ?thesis by (induction fs) auto next
      case (Nil) then show ?thesis by auto
    qed
  qed
qed



definition Gr where
"Gr =
 {
 (Δ0, {Δ0,Δ1,Δ2,Δ3}),
 (Δ1, {Δ1,Δ2,Δ3}),
 (Δ2, {Δ2,Δ1}),
 (Δ3, {Δ3,Δ1})
 }"


theorem secure: secure
apply (rule unwind_decomp_secure_graph[of Gr Δ0])
unfolding Gr_def
apply (simp, smt insert_subset order_refl)
using
istate_Δ0 unwind_cont_Δ0 unwind_cont_Δ1 unwind_cont_Δ2 unwind_cont_Δ3
unfolding Gr_def by (auto intro: unwind_cont_mono)

end

Theory Traceback_Intro

theory Traceback_Intro
  imports "../Safety_Properties"
begin


section ‹Traceback Properties›

text ‹In this section, we prove traceback properties. These properties
trace back the actions leading to:
\begin{itemize}
\item the current visibility status of a post
\item the current friendship status of two users
\end{itemize}
They state that the current status can only occur via a ``legal'' sequence of actions.
Because the BD properties have (dynamic triggers within) declassification bounds
that refer to such statuses, the traceback properties complement BD Security in adding
confidentiality assurance. \cite[Section 5.2]{cosmed-itp2016} gives more details and explanations.
›



end

Theory Post_Visibility_Traceback

theory Post_Visibility_Traceback
  imports Traceback_Intro
begin

consts PID :: postID
consts VIS :: vis

subsection ‹Tracing Back Post Visibility Status›

text ‹We prove the following traceback property:
If, at some point ‹t› on a system trace, the visibility of a post ‹PID›
has a value ‹VIS›, then one of the following holds:
\begin{itemize}
\item Either ‹VIS› is ‹FriendV› (i.e., friends-only) which is the default at post creation
\item Or the post's owner had issued a successful ``update visibility'' action setting the visibility to ‹VIS›,
and no other successful update actions to ‹PID›'s visibility occur
between the time of that action and ‹t›.
\end{itemize}

This will be captured in the predicate ‹proper›, and the main theorem states that ‹proper tr›
holds for any trace ‹tr› that leads to post ‹PID› acquiring visibility ‹VIS›.
›


text ‹‹SNC uidd trn› means
``The transaction ‹trn› is a successful post creation by user ‹uidd›'' ›

fun SNC :: "userID ⇒ (state,act,out) trans ⇒ bool" where
"SNC uidd (Trans s (Cact (cPost uid p pid tit)) ou s') = (ou = outOK ∧ (uid,pid) = (uidd,PID))"
|
"SNC uidd _ = False"


text ‹‹SNVU uidd vvs trn› means
"The transaction ‹trn› is a successful post visibility update for ‹PID›, by user ‹uidd›, to value ‹vvs›'' ›

fun SNVU :: "userID ⇒ vis ⇒ (state,act,out) trans ⇒ bool" where
"SNVU uidd vvs (Trans s (Uact (uVisPost uid p pid vs)) ou s') =
   (ou = outOK ∧ (uid,pid) = (uidd,PID) ∧ vs = vvs)"
|
"SNVU uidd vvis _ = False"

definition proper :: "(state,act,out) trans trace ⇒ bool" where
"proper tr ≡
 VIS = FriendV
 ∨
 (∃ uid tr1 trn tr2 trnn tr3.
    tr = tr1 @ trn # tr2 @ trnn # tr3 ∧
    SNC uid trn ∧ SNVU uid VIS trnn ∧ (∀ vis. never (SNVU uid vis) tr3))"

(*  *)

definition proper1 :: "(state,act,out) trans trace ⇒ bool" where
"proper1 tr ≡
 ∃ tr2 trnn tr3.
    tr = tr2 @ trnn # tr3 ∧
    SNVU (owner (srcOf trnn) PID) VIS trnn"

lemma not_never_ex:
assumes "¬ never P xs"
shows "∃ xs1 x xs2. xs = xs1 @ x # xs2 ∧ P x ∧ never P xs2"
using assms proof(induct xs rule: rev_induct)
  case (Nil)
  thus ?case unfolding list_all_iff empty_iff by auto
next
  case (snoc y ys)
  show ?case
  proof(cases "P y")
    case True thus ?thesis using snoc
    apply(intro exI[of _ ys]) apply(intro exI[of _ y] exI[of _ "[]"]) by auto
  next
    case False then obtain xs1 x xs2 where "ys = xs1 @ x # xs2 ∧ P x ∧ never P xs2"
    using snoc by auto
    thus ?thesis using snoc False
    apply(intro exI[of _ xs1]) apply(intro exI[of _ x] exI[of _ "xs2 ## y"]) by auto
  qed
qed

lemma SNVU_postIDs:
assumes "validTrans trn" and "SNVU uid vs trn"
shows "PID ∈∈ postIDs (srcOf trn)"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto simp: all_defs elim: step_elims)
qed

lemma SNVU_visib:
assumes "validTrans trn" and "SNVU uid vs trn"
shows "vis (tgtOf trn) PID = vs"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto simp: all_defs elim: step_elims)
qed

lemma owner_validTrans:
assumes "validTrans trn" and "PID ∈∈ postIDs (srcOf trn)"
shows "owner (srcOf trn) PID = owner (tgtOf trn) PID"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto simp: all_defs elim: step_elims)
qed

lemma owner_valid:
assumes "valid tr" and "PID ∈∈ postIDs (srcOf (hd tr))"
shows "owner (srcOf (hd tr)) PID = owner (tgtOf (last tr)) PID"
using assms using owner_validTrans IDs_mono validTrans by induct auto

lemma SNVU_vis_validTrans:
assumes "validTrans trn" and "PID ∈∈ postIDs (srcOf trn)"
and "∀ vs. ¬ SNVU (owner (srcOf trn) PID) vs trn"
shows "vis (srcOf trn) PID = vis (tgtOf trn) PID"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto simp: all_defs elim: step_elims)
qed

lemma SNVU_vis_valid:
assumes "valid tr" and "PID ∈∈ postIDs (srcOf (hd tr))"
and "∀ vis. never (SNVU (owner (srcOf (hd tr)) PID) vis) tr"
shows "vis (srcOf (hd tr)) PID = vis (tgtOf (last tr)) PID"
using assms proof induct
  case (Singl)
  thus ?case using SNVU_vis_validTrans by auto
next
  case (Cons trn tr)
  have n: "PID ∈∈ postIDs (srcOf (hd tr))"
  using Cons by (simp add: IDs_mono(2) validTrans)
  have v: "∀ vis. never (SNVU (owner (srcOf (hd tr)) PID) vis) tr"
  using Cons by (simp add: owner_validTrans)
  have "vis (srcOf trn) PID = vis (srcOf (hd tr)) PID"
  using Cons SNVU_vis_validTrans by auto
  also have "... = vis (tgtOf (last tr)) PID"
  using n v Cons(4) by auto
  finally show ?case using Cons by auto
qed

lemma proper1_never:
assumes vtr: "valid tr" and PID: "PID ∈∈ postIDs (srcOf (hd tr))"
and tr: "proper1 tr" and v: "vis (tgtOf (last tr)) PID = VIS"
shows "∃ tr2 trnn tr3.
    tr = tr2 @ trnn # tr3 ∧
    SNVU (owner (srcOf trnn) PID) VIS trnn ∧ (∀ vis. never (SNVU (owner (srcOf trnn) PID) vis) tr3)"
proof-
  obtain tr2 trnn tr3 where
  tr: "tr = tr2 @ trnn # tr3" and SNVU: "SNVU (owner (srcOf trnn) PID) VIS trnn"
  using tr unfolding proper1_def by auto
  define uid where "uid ≡ owner (srcOf trnn) PID"
  show ?thesis
  proof(cases "never (λ trn. ∃ vis. SNVU uid vis trn) tr3")
    case True thus ?thesis using tr SNVU unfolding uid_def list_all_iff by blast
  next
    case False
    from not_never_ex[OF this] obtain tr3a tr3n tr3b vs where tr3: "tr3 = tr3a @ tr3n # tr3b"
    and SNVUtr3n: "SNVU uid vs tr3n" and n: "∀ vs. never (SNVU uid vs) tr3b"
    unfolding list_all_iff by blast
    have trnn: "validTrans trnn" and
    tr3n: "validTrans tr3n" and vtr3: "valid tr3" using tr unfolding tr tr3
    by (metis Nil_is_append_conv append_self_conv2 list.distinct(1) tr tr3 valid_ConsE valid_append vtr)+
    hence PID_trnn: "PID ∈∈ postIDs (srcOf trnn)" and
    PID_tr3n: "PID ∈∈ postIDs (srcOf tr3n)" using SNVU_postIDs SNVU SNVUtr3n by auto
    have vvv: "valid (trnn # tr3a @ [tr3n])"
    using vtr unfolding tr tr3
    by (smt Nil_is_append_conv append_self_conv2 hd_append2 list.distinct(1) list.sel(1)
        valid_Cons_iff valid_append)
    hence PID_tr3n': "PID ∈∈ postIDs (tgtOf tr3n)" using tr3n SNVUtr3n
    by (simp add: IDs_mono(2) PID_tr3n validTrans)
    from owner_valid[OF vvv] PID_trnn
    have 000: "owner (tgtOf tr3n) PID = uid" unfolding uid_def by simp
    hence 0: "owner (srcOf tr3n) PID = uid" using PID_tr3n owner_validTrans tr3n by blast
    have 00: "vs = vis (tgtOf tr3n) PID" using SNVUtr3n tr3n SNVU_visib by auto
    have vis: "vs = VIS"
    proof(cases "tr3b = []")
      case True
      thus ?thesis using v 00 unfolding tr tr3 by simp
    next
      case False
      hence tgt: "tgtOf tr3n = srcOf (hd tr3b)" and tr3b: "valid tr3b" using vtr3 unfolding tr3
      apply (metis valid_append list.distinct(2) self_append_conv2 valid_ConsE)
      by (metis False append_self_conv2 list.distinct(1) tr3 valid_Cons_iff valid_append vtr3)
      show ?thesis unfolding 00 tgt
        using v False PID_tr3n'
        using SNVU_vis_valid[OF tr3b _ n[unfolded 000[symmetric] tgt]]
      unfolding tr tr3 tgt by simp
    qed
    show ?thesis apply(intro exI[of _ "tr2 @ trnn # tr3a"])
    apply(intro exI[of _ tr3n] exI[of _ tr3b])
    using SNVUtr3n n unfolding tr tr3 0 vis by simp
  qed
qed


(* *)

lemma SNVU_validTrans:
assumes "validTrans trn"
and "PID ∈∈ postIDs (srcOf trn)"
and "vis (srcOf trn) PID ≠ VIS"
and "vis (tgtOf trn) PID = VIS"
shows "SNVU (owner (srcOf trn) PID) VIS trn"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto simp: all_defs elim: step_elims)
qed

lemma valid_mono_postID:
assumes "valid tr"
and "PID ∈∈ postIDs (srcOf (hd tr))"
shows "PID ∈∈ postIDs (tgtOf (last tr))"
using assms proof induct
  case (Singl trn)
  then show ?case using IDs_mono(2) by (cases trn) auto
next
  case (Cons trn tr)
  then show ?case using IDs_mono(2) by (cases trn) auto
qed

lemma proper1_valid:
assumes V: "VIS ≠ FriendV"
and a: "valid tr"
"PID ∈∈ postIDs (srcOf (hd tr))"
"vis (srcOf (hd tr)) PID ≠ VIS"
"vis (tgtOf (last tr)) PID = VIS"
shows "proper1 tr"
using a unfolding valid_valid2 proof induct
  case (Singl trn)
  then show ?case unfolding proper1_def using SNVU_validTrans
  by (intro exI[of _ "owner (srcOf trn) PID"] exI[of _ "[]"] exI[of _ trn]) auto
next
  case (Rcons tr trn)
  hence "PID ∈∈ postIDs (srcOf (hd tr))" using Rcons by simp
  from valid_mono_postID[OF ‹valid2 tr›[unfolded valid2_valid] this]
  have "PID ∈∈ postIDs (tgtOf (last tr))" by simp
  hence 0: "PID ∈∈ postIDs (srcOf trn)" using Rcons by simp
  show ?case
  proof(cases "vis (srcOf trn) PID = VIS")
    case False
    hence "SNVU (owner (srcOf trn) PID) VIS trn"
    apply (intro SNVU_validTrans) using 0 Rcons by auto
    thus ?thesis unfolding proper1_def
    by (intro exI[of _ tr] exI[of _ trn] exI[of _ "[]"]) auto
  next
    case True
    hence "proper1 tr" using Rcons by auto
    then obtain trr trnn tr3 where
    tr: "tr = trr @ trnn # tr3" and SNVU: "SNVU (owner (srcOf trnn) PID) VIS trnn"
    unfolding proper1_def using V by auto
    have "vis (tgtOf trn) PID = VIS" using Rcons.prems by auto
    thus ?thesis
    using SNVU V unfolding proper1_def tr
    by(intro exI[of _ trr] exI[of _ trnn] exI[of _ "tr3 ## trn"]) auto
  qed
qed

lemma istate_postIDs:
"¬ PID ∈∈ postIDs istate"
unfolding istate_def by simp


(* *)

definition proper2 :: "(state,act,out) trans trace ⇒ bool" where
"proper2 tr ≡
 ∃ uid tr1 trn tr2.
    tr = tr1 @ trn # tr2 ∧ SNC uid trn"

lemma SNC_validTrans:
assumes "VIS ≠ FriendV" and "validTrans trn"
and "¬ PID ∈∈ postIDs (srcOf trn)"
and "PID ∈∈ postIDs (tgtOf trn)"
shows "∃ uid. SNC uid trn"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto simp: all_defs elim: step_elims)
qed

lemma proper2_valid:
assumes V: "VIS ≠ FriendV"
and a: "valid tr"
"¬ PID ∈∈ postIDs (srcOf (hd tr))"
"PID ∈∈ postIDs (tgtOf (last tr))"
shows "proper2 tr"
using a unfolding valid_valid2 proof induct
  case (Singl trn)
  then obtain uid where "SNC uid trn" using SNC_validTrans V by auto
  thus ?case unfolding proper2_def using SNC_validTrans
  by (intro exI[of _ uid] exI[of _ "[]"]  exI[of _ trn]) auto
next
  case (Rcons tr trn)
  show ?case
  proof(cases "PID ∈∈ postIDs (srcOf trn)")
    case False
    then obtain uid where "SNC uid trn"
    using Rcons SNC_validTrans V by auto
    thus ?thesis unfolding proper2_def
    apply - apply (intro exI[of _ uid] exI[of _ tr]) by (intro exI[of _ trn] exI[of _ "[]"]) auto
  next
    case True
    hence "proper2 tr" using Rcons by auto
    then obtain uid tr1 trnn tr2 where
    tr: "tr = tr1 @ trnn # tr2" and SFRC: "SNC uid trnn"
    unfolding proper2_def by auto
    have "PID ∈∈ postIDs (tgtOf trn)" using V Rcons.prems by auto
    show ?thesis using SFRC unfolding proper2_def tr
    apply - apply (intro exI[of _ uid] exI[of _ tr1])
    by (intro exI[of _ trnn] exI[of _ "tr2 ## trn"]) simp
  qed
qed

lemma proper2_valid_istate:
assumes V: "VIS ≠ FriendV"
and a: "valid tr"
"srcOf (hd tr) = istate"
"PID ∈∈ postIDs (tgtOf (last tr))"
shows "proper2 tr"
using proper2_valid assms istate_postIDs by auto

(* *)

lemma SNC_visPost:
assumes "VIS ≠ FriendV"
and "validTrans trn" "SNC uid trn" and "reach (srcOf trn)"
shows "vis (tgtOf trn) PID ≠ VIS"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    apply (cases "a") apply (auto simp: all_defs elim: step_elims)
    subgoal for x2 apply(cases x2)
      using reach_not_postIDs_vis_FriendV
      by (auto simp: all_defs elim: step_elims) .
qed

lemma SNC_postIDs:
assumes "validTrans trn" and "SNC uid trn"
shows "PID ∈∈ postIDs (tgtOf trn)"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto simp: all_defs elim: step_elims)
qed

lemma SNC_owner:
assumes "validTrans trn" and "SNC uid trn"
shows "uid = owner (tgtOf trn) PID"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto simp: all_defs elim: step_elims)
qed

theorem post_accountability:
assumes v: "valid tr" and i: "srcOf (hd tr) = istate"
and PIDin: "PID ∈∈ postIDs (tgtOf (last tr))"
and PID: "vis (tgtOf (last tr)) PID = VIS"
shows "proper tr"
proof(cases "VIS = FriendV")
  case True thus ?thesis unfolding proper_def by auto
next
  case False
  have "proper2 tr" using proper2_valid_istate[OF False v i PIDin] .
  then obtain uid tr1 trn trr where
  tr: "tr = tr1 @ trn # trr" and SNC: "SNC uid trn" unfolding proper2_def by auto
  hence trn: "validTrans trn" and r: "reach (srcOf trn)" using v unfolding tr
    apply (metis list.distinct(2) self_append_conv2 valid_ConsE valid_append)
    by (metis (mono_tags, lifting) append_Cons hd_append i list.sel(1) reach.simps tr v valid_append valid_init_reach)
  hence N: "PID ∈∈ postIDs (tgtOf trn)" "vis (tgtOf trn) PID ≠ VIS"
  using SNC_postIDs SNC_visPost False SNC by auto
  hence trrNE: "trr ≠ []" and 1: "last tr = last trr" using PID unfolding tr by auto
  hence trr_v: "valid trr" using v unfolding tr
  by (metis valid_Cons_iff append_self_conv2 list.distinct(1) valid_append)
  have 0: "tgtOf trn = srcOf (hd trr)" using v trrNE unfolding tr
  by (metis valid_append list.distinct(2) self_append_conv2 valid_ConsE)
  have "proper1 trr" using proper1_valid[OF False trr_v N[unfolded 0] PID[unfolded 1]] .
  from proper1_never[OF trr_v N(1)[unfolded 0] this PID[unfolded 1]] obtain tr2 trnn tr3 where
  trr: "trr = tr2 @ trnn # tr3" and SNVU: "SNVU (owner (srcOf trnn) PID) VIS trnn"
  and vis: "∀ vis. never (SNVU (owner (srcOf trnn) PID) vis) tr3" by auto
  have 00: "srcOf (hd (tr2 @ [trnn])) = tgtOf trn" using v unfolding tr trr
  by (metis "0" append_self_conv2 hd_append2 list.sel(1) trr)
  have trnn: "validTrans trnn" using trr_v unfolding trr
  by (metis valid_Cons_iff append_self_conv2 list.distinct(1) valid_append)
  have vv: "valid (tr2 @ [trnn])"
  using v unfolding tr trr
  by (smt Nil_is_append_conv append_self_conv2 hd_append2 list.distinct(1) list.sel(1)
        valid_Cons_iff valid_append)
  have "uid = owner (tgtOf trn) PID" using SNC trn SNC_owner by auto
  also have "... = owner (tgtOf trnn) PID"
  using owner_valid[OF vv] N(1) unfolding 00 by simp
  also have "... = owner (srcOf trnn) PID"
  using SNVU trnn SNVU_postIDs owner_validTrans by auto
  finally have uid: "uid = owner (srcOf trnn) PID" .
  show ?thesis unfolding proper_def
  apply(rule disjI2)
  apply(intro exI[of _ uid] exI[of _ tr1])
  apply(rule exI[of _ trn], rule exI[of _ tr2])
  apply(intro exI[of _ trnn] exI[of _ tr3])
  using SNC SNVU vis unfolding tr trr uid by auto
qed


end

Theory Friend_Traceback

theory Friend_Traceback
imports Traceback_Intro
begin


subsection ‹Tracing Back Friendship Status›

text ‹We prove the following traceback property:
If, at some point ‹t› on a system trace, the users ‹UID› and ‹UID'› are friends,
then one of the following holds:
\begin{itemize}
\item Either ‹UID› had issued a friend request to ‹UID'›, eventually followed by an approval
(i.e., a successful ‹UID›-friend creation action) by ‹UID'› such that between
that approval and ‹t› there was no successful ‹UID'›-unfriending (i.e., friend deletion)
by ‹UID› or ‹UID›-unfriending by ‹UID'›
\item Or vice versa (with ‹UID› and ‹UID'› swapped)
\end{itemize}

This property is captured by the predicate ‹proper›, which decomposes any valid system trace tr
starting in the initial state
for which the target state ‹tgtOf (last tr)› has ‹UID› and ‹UID'› as friends,
as follows: tr is the concatenation of ‹tr1›, ‹trn›, ‹tr2›, ‹trnn› and ‹tr3› where
\begin{itemize}
\item ‹trn› represents the time of the relevant friend request
\item ‹trnn› represents the time of the approval of this request
\item ‹tr3› contains no unfriending between the two users
\end{itemize}

The main theorem states that ‹proper tr›
holds for any trace ‹tr› that leads to ‹UID› and ‹UID'› being friends.
›

consts UID :: userID
consts UID' :: userID

text ‹‹SFRC› means ``is a successful friend request creation''›

fun SFRC :: "userID ⇒ userID ⇒ (state,act,out) trans ⇒ bool" where
"SFRC uidd uidd' (Trans s (Cact (cFriendReq uid p uid' _)) ou s') = (ou = outOK ∧ (uid,uid') = (uidd,uidd'))"
|
"SFRC uidd uidd' _ = False"

text ‹‹SFC› means ``is a successful friend creation'' ›

fun SFC :: "userID ⇒ userID ⇒ (state,act,out) trans ⇒ bool" where
"SFC uidd uidd' (Trans s (Cact (cFriend uid p uid')) ou s') = (ou = outOK ∧ (uid,uid') = (uidd,uidd'))"
|
"SFC uidd uidd' _ = False"

text ‹‹SFD› means ``is a successful friend deletion'' ›

fun SFD :: "userID ⇒ userID ⇒ (state,act,out) trans ⇒ bool" where
"SFD uidd uidd' (Trans s (Dact (dFriend uid p uid')) ou s') = (ou = outOK ∧ (uid,uid') = (uidd,uidd'))"
|
"SFD uidd uidd' _ = False"

definition proper1 :: "(state,act,out) trans trace ⇒ bool" where
"proper1 tr ≡
 ∃ trr trnn tr3. tr = trr @ trnn # tr3 ∧
                 (SFC UID UID' trnn ∨ SFC UID' UID trnn) ∧
                 never (SFD UID UID') tr3 ∧ never (SFD UID' UID) tr3"

lemma SFC_validTrans:
assumes "validTrans trn"
and "¬ UID' ∈∈ friendIDs (srcOf trn) UID"
and "UID' ∈∈ friendIDs (tgtOf trn) UID"
shows "SFC UID UID' trn ∨ SFC UID' UID trn"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases a) (auto elim: step_elims simp: all_defs)
qed

lemma SFD_validTrans:
assumes "validTrans trn"
and "UID' ∈∈ friendIDs (tgtOf trn) UID"
shows "¬ SFD UID UID' trn ∧ ¬ SFD UID' UID trn"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases a) (auto elim: step_elims simp: all_defs)
qed

lemma SFC_SFD:
assumes "SFC uid1 uid2 trn" shows "¬ SFD uid3 uid4 trn"
proof(cases trn)
  case (Trans s a ou s') note trn = Trans
  show ?thesis using assms unfolding trn
  by (cases "a") auto
qed

lemma proper1_valid:
assumes "valid tr"
and "¬ UID' ∈∈ friendIDs (srcOf (hd tr)) UID"
and "UID' ∈∈ friendIDs (tgtOf (last tr)) UID"
shows "proper1 tr"
using assms unfolding valid_valid2 proof induct
  case (Singl trn)
  then show ?case unfolding proper1_def using SFC_validTrans
  by (intro exI[of _ "[]"] exI[of _ trn]) auto
next
  case (Rcons tr trn)
  show ?case
  proof(cases "UID' ∈∈ friendIDs (srcOf trn) UID")
    case False
    hence "SFC UID UID' trn ∨ SFC UID' UID trn"
    using Rcons SFC_validTrans by auto
    thus ?thesis unfolding proper1_def
    apply - apply (rule exI[of _ tr]) by (intro exI[of _ trn] exI[of _ "[]"]) auto
  next
    case True
    hence "proper1 tr" using Rcons by auto
    then obtain trr trnn tr3 where
    tr: "tr = trr @ trnn # tr3" and
    SFC: "SFC UID UID' trnn ∨ SFC UID' UID trnn" and
    n: "never (SFD UID UID') tr3 ∧ never (SFD UID' UID) tr3"
    unfolding proper1_def by auto
    have "UID' ∈∈ friendIDs (tgtOf trn) UID" using Rcons.prems(2) by auto
    hence SFD: "¬ SFD UID UID' trn ∧ ¬ SFD UID' UID trn"
    using SFD_validTrans ‹validTrans trn› by auto
    show ?thesis using SFC n SFD unfolding proper1_def tr
    apply - apply (rule exI[of _ trr])
    by (intro exI[of _ trnn] exI[of _ "tr3 ## trn"]) simp
  qed
qed

lemma istate_friendIDs:
"¬ UID' ∈∈ friendIDs (istate) UID"
unfolding istate_def by simp

lemma proper1_valid_istate:
assumes "valid tr" and "srcOf (hd tr) = istate"
and "UID' ∈∈ friendIDs (tgtOf (last tr)) UID"
shows "proper1 tr"
using assms istate_friendIDs proper1_valid by auto

(*  *)

definition proper2 :: "userID ⇒ userID ⇒ (state,act,out) trans trace ⇒ bool" where
"proper2 uid uid' tr ≡
 ∃ tr1 trnn tr2. tr = tr1 @ trnn # tr2 ∧ SFRC uid uid' trnn"

lemma SFRC_validTrans:
assumes "validTrans trn"
and "¬ uid ∈∈ pendingFReqs (srcOf trn) uid'"
and "uid ∈∈ pendingFReqs (tgtOf trn) uid'"
shows "SFRC uid uid' trn"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto elim: step_elims simp: all_defs)
qed

lemma proper2_valid:
assumes "valid tr"
and "¬ uid ∈∈ pendingFReqs (srcOf (hd tr)) uid'"
and "uid ∈∈ pendingFReqs (tgtOf (last tr)) uid'"
shows "proper2 uid uid' tr"
using assms unfolding valid_valid2 proof induct
  case (Singl trn)
  thus ?case unfolding proper2_def using SFRC_validTrans
  by (intro exI[of _ "[]"] exI[of _ trn]) auto
next
  case (Rcons tr trn)
  show ?case
  proof(cases "uid ∈∈ pendingFReqs (srcOf trn) uid'")
    case False
    hence "SFRC uid uid' trn"
    using Rcons SFRC_validTrans by auto
    thus ?thesis unfolding proper2_def
    apply - apply (rule exI[of _ tr]) by (intro exI[of _ trn] exI[of _ "[]"]) auto
  next
    case True
    hence "proper2 uid uid' tr" using Rcons by auto
    then obtain trr trnn tr3 where
    tr: "tr = trr @ trnn # tr3" and SFRC: "SFRC uid uid' trnn"
    unfolding proper2_def by auto
    have "uid ∈∈ pendingFReqs (tgtOf trn) uid'" using Rcons.prems(2) by auto
    show ?thesis using SFRC unfolding proper2_def tr
    apply - apply (rule exI[of _ trr])
    by (intro exI[of _ trnn] exI[of _ "tr3 ## trn"]) simp
  qed
qed

lemma istate_pendingFReqs:
"¬ uid ∈∈ pendingFReqs (istate) uid'"
unfolding istate_def by simp

lemma proper2_valid_istate:
assumes "valid tr" and "srcOf (hd tr) = istate"
and "uid ∈∈ pendingFReqs (tgtOf (last tr)) uid'"
shows "proper2 uid uid' tr"
using assms istate_pendingFReqs proper2_valid by auto

(*  *)

lemma SFC_pendingFReqs:
assumes "validTrans trn"
and "SFC uid' uid trn"
shows "uid ∈∈ pendingFReqs (srcOf trn) uid'"
proof(cases trn)
  case (Trans s a ou s')
  then show ?thesis
    using assms
    by (cases "a") (auto elim: step_elims simp: all_defs)
qed


definition proper :: "(state,act,out) trans trace ⇒ bool" where
"proper tr ≡
 ∃ tr1 trn tr2 trnn tr3. tr = tr1 @ trn # tr2 @ trnn # tr3 ∧
                 (SFRC UID' UID trn ∧ SFC UID UID' trnn ∨
                  SFRC UID UID' trn ∧ SFC UID' UID trnn) ∧
                 never (SFD UID UID') tr3 ∧ never (SFD UID' UID) tr3"

theorem friend_accountability:
assumes v: "valid tr" and i: "srcOf (hd tr) = istate"
and UID: "UID' ∈∈ friendIDs (tgtOf (last tr)) UID"
shows "proper tr"
proof-
  have "proper1 tr" using proper1_valid_istate[OF assms] .
  then obtain trr trnn tr3 where
  tr: "tr = trr @ trnn # tr3" and
  SFC: "SFC UID UID' trnn ∨ SFC UID' UID trnn" (is "?A ∨ ?B") and
  n: "never (SFD UID UID') tr3 ∧ never (SFD UID' UID) tr3"
  unfolding proper1_def by auto
  have trnn: "validTrans trnn" and trr: "valid trr" using tr
  apply (metis valid_Cons_iff append_self_conv2 assms(1) list.distinct(1) valid_append)
  by (metis SFC SFC_pendingFReqs append_self_conv2 i istate_pendingFReqs list.distinct(1) list.sel(1) tr v valid_Cons_iff valid_append)
  show ?thesis using SFC proof
    assume SFC: ?A
    have 0: "UID' ∈∈ pendingFReqs (srcOf trnn) UID"
    using SFC_pendingFReqs[OF trnn SFC] .
    hence "srcOf trnn ≠ istate" unfolding istate_def by auto
    hence 2: "trr ≠ []" using i unfolding tr by auto
    hence i: "srcOf (hd trr) = istate" using i unfolding tr by auto
    have "srcOf trnn = tgtOf (last trr)" using tr v valid_append 2 by auto
    hence 1: "UID' ∈∈ pendingFReqs (tgtOf (last trr)) UID" using 0 by simp
    have "proper2 UID' UID trr" using proper2_valid_istate[OF trr i 1] .
    then obtain tr1 trn tr2 where
    trr: "trr = tr1 @ trn # tr2" and SFRC: "SFRC UID' UID trn"
    unfolding proper2_def by auto
    show ?thesis unfolding proper_def
    apply(rule exI[of _ tr1], rule exI[of _ trn], rule exI[of _ tr2],
          rule exI[of _ trnn], rule exI[of _ tr3])
    unfolding tr trr using SFRC SFC n by simp
  next
    assume SFC: ?B
    have 0: "UID ∈∈ pendingFReqs (srcOf trnn) UID'"
    using SFC_pendingFReqs[OF trnn SFC] .
    hence "srcOf trnn ≠ istate" unfolding istate_def by auto
    hence 2: "trr ≠ []" using i unfolding tr by auto
    hence i: "srcOf (hd trr) = istate" using i unfolding tr by auto
    have "srcOf trnn = tgtOf (last trr)" using tr v valid_append 2 by auto
    hence 1: "UID ∈∈ pendingFReqs (tgtOf (last trr)) UID'" using 0 by simp
    have "proper2 UID UID' trr" using proper2_valid_istate[OF trr i 1] .
    then obtain tr1 trn tr2 where
    trr: "trr = tr1 @ trn # tr2" and SFRC: "SFRC UID UID' trn"
    unfolding proper2_def by auto
    show ?thesis unfolding proper_def
    apply(rule exI[of _ tr1], rule exI[of _ trn], rule exI[of _ tr2],
          rule exI[of _ trnn], rule exI[of _ tr3])
    unfolding tr trr using SFRC SFC n by simp
  qed
qed



end